2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
30 module F
= Control_flow_c
32 module Flag
= Flag_matcher
34 (*****************************************************************************)
36 (*****************************************************************************)
37 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
39 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
46 (Printf.sprintf
"%s: %d: %s"
47 (Ast_c.file_of_info ii
) (Ast_c.line_of_info ii
) str
)
49 (*****************************************************************************)
51 (*****************************************************************************)
53 type sequence
= Ordered
| Unordered
56 match A.unwrap eas
with
58 | A.CIRCLES _
-> Unordered
59 | A.STARS _
-> failwith
"not handling stars"
61 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
63 match A.unwrap eas
with
64 | A.DOTS _
-> A.DOTS easundots
65 | A.CIRCLES _
-> A.CIRCLES easundots
66 | A.STARS _
-> A.STARS easundots
70 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
72 ibs
+> List.exists
(fun (ib
, icomma
) ->
73 match B.unwrap ib
with
82 (* For the #include <linux/...> in the .cocci, need to find where is
83 * the '+' attached to this element, to later find the first concrete
84 * #include <linux/xxx.h> or last one in the series of #includes in the
87 type include_requirement
=
94 (* todo? put in semantic_c.ml *)
97 | LocalFunction
(* entails Function *)
101 let term mc
= A.unwrap_mcode mc
102 let mcodekind mc
= A.get_mcodekind mc
105 let mcode_contain_plus = function
106 | A.CONTEXT
(_
,A.NOTHING
) -> false
107 | A.CONTEXT _
-> true
108 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> false
109 | A.MINUS
(_
,_
,_
,A.REPLACEMENT _
) -> true (* repl is nonempty *)
110 | A.PLUS _
-> raise Impossible
112 let mcode_simple_minus = function
113 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> true
117 (* In transformation.ml sometime I build some mcodekind myself and
118 * julia has put None for the pos. But there is no possible raise
119 * NoMatch in those cases because it is for the minusall trick or for
120 * the distribute, so either have to build those pos, in fact a range,
121 * because for the distribute have to erase a fullType with one
122 * mcodekind, or add an argument to tag_with_mck such as "safe" that
123 * don't do the check_pos. Hence this DontCarePos constructor. *)
127 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
128 (A.MINUS
(A.DontCarePos
,[],A.ALLMINUS
,A.NOREPLACEMENT
)),
131 let generalize_mcode ia
=
132 let (s1
, i
, mck
, pos
) = ia
in
135 | A.PLUS _
-> raise Impossible
136 | A.CONTEXT
(A.NoPos
,x
) ->
137 A.CONTEXT
(A.DontCarePos
,x
)
138 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
139 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
141 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
142 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
146 (s1
, i
, new_mck, pos
)
150 (*---------------------------------------------------------------------------*)
152 (* 0x0 is equivalent to 0, value format isomorphism *)
153 let equal_c_int s1 s2
=
155 int_of_string s1
=|= int_of_string s2
156 with Failure
("int_of_string") ->
161 (*---------------------------------------------------------------------------*)
162 (* Normally A should reuse some types of Ast_c, so those
163 * functions should not exist.
165 * update: but now Ast_c depends on A, so can't make too
166 * A depends on Ast_c, so have to stay with those equal_xxx
170 let equal_unaryOp a b
=
172 | A.GetRef
, B.GetRef
-> true
173 | A.GetRefLabel
, B.GetRefLabel
-> true
174 | A.DeRef
, B.DeRef
-> true
175 | A.UnPlus
, B.UnPlus
-> true
176 | A.UnMinus
, B.UnMinus
-> true
177 | A.Tilde
, B.Tilde
-> true
178 | A.Not
, B.Not
-> true
179 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
|B.GetRefLabel
) ->
184 let equal_arithOp a b
=
186 | A.Plus
, B.Plus
-> true
187 | A.Minus
, B.Minus
-> true
188 | A.Mul
, B.Mul
-> true
189 | A.Div
, B.Div
-> true
190 | A.Mod
, B.Mod
-> true
191 | A.DecLeft
, B.DecLeft
-> true
192 | A.DecRight
, B.DecRight
-> true
193 | A.And
, B.And
-> true
194 | A.Or
, B.Or
-> true
195 | A.Xor
, B.Xor
-> true
196 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
199 let equal_logicalOp a b
=
201 | A.Inf
, B.Inf
-> true
202 | A.Sup
, B.Sup
-> true
203 | A.InfEq
, B.InfEq
-> true
204 | A.SupEq
, B.SupEq
-> true
205 | A.Eq
, B.Eq
-> true
206 | A.NotEq
, B.NotEq
-> true
207 | A.AndLog
, B.AndLog
-> true
208 | A.OrLog
, B.OrLog
-> true
209 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
212 let equal_assignOp a b
=
214 | A.SimpleAssign
, B.SimpleAssign
-> true
215 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
216 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
218 let equal_fixOp a b
=
220 | A.Dec
, B.Dec
-> true
221 | A.Inc
, B.Inc
-> true
222 | _
, (B.Inc
|B.Dec
) -> false
224 let equal_binaryOp a b
=
226 | A.Arith a
, B.Arith b
-> equal_arithOp a b
227 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
228 | _
, (B.Logical _
| B.Arith _
) -> false
230 let equal_structUnion a b
=
232 | A.Struct
, B.Struct
-> true
233 | A.Union
, B.Union
-> true
234 | _
, (B.Struct
|B.Union
) -> false
238 | A.Signed
, B.Signed
-> true
239 | A.Unsigned
, B.UnSigned
-> true
240 | _
, (B.UnSigned
|B.Signed
) -> false
242 let equal_storage a b
=
244 | A.Static
, B.Sto
B.Static
245 | A.Auto
, B.Sto
B.Auto
246 | A.Register
, B.Sto
B.Register
247 | A.Extern
, B.Sto
B.Extern
249 | _
, (B.NoSto
| B.StoTypedef
) -> false
250 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
253 (*---------------------------------------------------------------------------*)
255 let equal_metavarval valu valu'
=
256 match valu
, valu'
with
257 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
258 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
259 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
260 (* do something more ? *)
263 (* al_expr before comparing !!! and accept when they match.
264 * Note that here we have Astc._expression, so it is a match
265 * modulo isomorphism (there is no metavariable involved here,
266 * just isomorphisms). => TODO call isomorphism_c_c instead of
267 * =*=. Maybe would be easier to transform ast_c in ast_cocci
268 * and call the iso engine of julia. *)
269 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
270 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
271 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
272 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
274 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
275 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
276 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
277 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
278 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
279 Lib_parsing_c.al_fields a
=*= Lib_parsing_c.al_fields b
280 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
281 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
282 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
283 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
284 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
285 Lib_parsing_c.al_inits a
=*= Lib_parsing_c.al_inits b
286 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
287 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
290 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
292 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
293 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
294 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
295 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
297 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
298 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
300 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
302 (function (fla
,cea
,posa1
,posa2
) ->
304 (function (flb
,ceb
,posb1
,posb2
) ->
305 fla
=$
= flb
&& cea
=$
= ceb
&&
306 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
310 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
311 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
312 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
313 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
314 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
318 (* probably only one argument needs to be stripped, because inherited
319 metavariables containing expressions are stripped in advance. But don't
320 know which one is which... *)
321 let equal_inh_metavarval valu valu'
=
322 match valu
, valu'
with
323 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
324 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
325 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
326 (* do something more ? *)
329 (* al_expr before comparing !!! and accept when they match.
330 * Note that here we have Astc._expression, so it is a match
331 * modulo isomorphism (there is no metavariable involved here,
332 * just isomorphisms). => TODO call isomorphism_c_c instead of
333 * =*=. Maybe would be easier to transform ast_c in ast_cocci
334 * and call the iso engine of julia. *)
335 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
336 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
337 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
338 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
340 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
341 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
342 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
343 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
344 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
345 Lib_parsing_c.al_inh_field_list a
=*= Lib_parsing_c.al_inh_field_list b
346 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
347 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
348 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
349 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
350 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
351 Lib_parsing_c.al_inh_inits a
=*= Lib_parsing_c.al_inh_inits b
352 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
353 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
356 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
358 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
359 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
360 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
361 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
363 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
364 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
366 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
368 (function (fla
,cea
,posa1
,posa2
) ->
370 (function (flb
,ceb
,posb1
,posb2
) ->
371 fla
=$
= flb
&& cea
=$
= ceb
&&
372 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
376 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
377 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
378 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
379 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
380 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
385 (*---------------------------------------------------------------------------*)
386 (* could put in ast_c.ml, next to the split/unsplit_comma *)
387 let split_signb_baseb_ii (baseb
, ii
) =
388 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
389 match baseb
, iis with
391 | B.Void
, ["void",i1
] -> None
, [i1
]
393 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
394 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
395 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
397 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
400 | B.IntType
(B.Si
(sign
, base
)), xs
->
404 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
405 | (B.Signed
,rest
) -> (None
,rest
)
406 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
407 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
408 (* The original code only allowed explicit signed and unsigned for char,
409 while this code allows char by itself. Not sure that needs to be
410 checked for here. If it does, then add a special case. *)
412 match (base
,rest
) with
413 B.CInt
, ["int",i1
] -> [i1
]
416 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
417 (match i1
.B.pinfo
with
419 | _
-> error [i1
] ("unrecognized signed int: "^
420 (String.concat
" "(List.map fst
iis))))
422 | B.CChar2
, ["char",i2
] -> [i2
]
424 | B.CShort
, ["short",i1
] -> [i1
]
425 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
427 | B.CLong
, ["long",i1
] -> [i1
]
428 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
430 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
431 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
434 error (List.map snd
iis)
435 ("strange type1, maybe because of weird order: "^
436 (String.concat
" " (List.map fst
iis))) in
439 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
440 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
441 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
444 error (List.map snd
iis)
445 ("strange type2, maybe because of weird order: "^
446 (String.concat
" " (List.map fst
iis)))
448 (*---------------------------------------------------------------------------*)
450 let rec unsplit_icomma xs
=
454 (match A.unwrap y
with
456 (x
, y
)::unsplit_icomma xs
457 | _
-> failwith
"wrong ast_cocci in initializer"
460 failwith
("wrong ast_cocci in initializer, should have pair " ^
465 let resplit_initialiser ibs iicomma
=
466 match iicomma
, ibs
with
469 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
471 error iicommas
"shouldn't have a iicomma"
472 | [iicomma
], x
::xs
->
473 let elems = List.map fst
(x
::xs
) in
474 let commas = List.map snd
(x
::xs
) +> List.flatten
in
475 let commas = commas @ [iicomma
] in
477 | _
-> raise Impossible
481 let rec split_icomma xs
=
484 | (x
,y
)::xs
-> x
::y
::split_icomma xs
486 let rec unsplit_initialiser ibs_unsplit
=
487 match ibs_unsplit
with
488 | [] -> [], [] (* empty iicomma *)
490 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
491 (x
, [])::xs
, lastcomma
493 and unsplit_initialiser_bis comma_before
= function
494 | [] -> [], [comma_before
]
496 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
497 (x
, [comma_before
])::xs
, lastcomma
502 (*---------------------------------------------------------------------------*)
503 (* coupling: same in type_annotater_c.ml *)
504 let structdef_to_struct_name ty
=
506 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
508 | Some s
, [i1
;i2
;i3
;i4
] ->
509 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
513 | x
-> raise Impossible
515 | _
-> raise Impossible
517 (*---------------------------------------------------------------------------*)
518 let one_initialisation_to_affectation x
=
519 let ({B.v_namei
= var
;
520 B.v_type
= returnType
;
521 B.v_type_bis
= tybis
;
522 B.v_storage
= storage
;
526 | Some
(name
, iniopt
) ->
528 | B.ValInit
(iini
, (B.InitExpr e
, ii_empty2
)) ->
531 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
533 Ast_c.LocalVar
(Ast_c.info_of_type returnType
) in
535 (* old: Lib_parsing_c.al_type returnType
536 * but this type has not the typename completed so
537 * instead try to use tybis
540 | Some ty_with_typename_completed
-> ty_with_typename_completed
541 | None
-> raise Impossible
544 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
546 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
548 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
553 let initialisation_to_affectation decl
=
555 | B.MacroDecl _
-> F.Decl decl
556 | B.DeclList
(xs
, iis) ->
558 (* todo?: should not do that if the variable is an array cos
559 * will have x[] = , mais de toute facon ca sera pas un InitExp
561 let possible_assignment =
565 match prev
,one_initialisation_to_affectation x
with
567 | None
,Some x
-> Some x
568 | Some prev
,Some x
->
569 (* [] is clearly an invalid ii value for a sequence.
570 hope that no one looks at it, since nothing will
571 match the sequence. Fortunately, SmPL doesn't
572 support , expressions. *)
573 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
575 match possible_assignment with
576 Some x
-> F.DefineExpr x
577 | None
-> F.Decl decl
579 (*****************************************************************************)
580 (* Functor parameter combinators *)
581 (*****************************************************************************)
583 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
585 * version0: was not tagging the SP, so just tag the C
587 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
588 * val return : 'b -> tin -> 'b tout
589 * val fail : tin -> 'b tout
591 * version1: now also tag the SP so return a ('a * 'b)
594 type mode
= PatternMode
| TransformMode
602 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
607 (tin
-> ('a
* 'b
) tout
) ->
608 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
609 (tin
-> ('c
* 'd
) tout
)
611 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
612 val fail
: tin
-> ('a
* 'b
) tout
624 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
626 val tokenf
: ('a
A.mcode
, B.info
) matcher
627 val tokenf_mck
: (A.mcodekind, B.info
) matcher
630 (A.meta_name
A.mcode
, B.expression
) matcher
632 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
634 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
636 (A.meta_name
A.mcode
,
637 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
639 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
641 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
643 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
645 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
647 (A.meta_name
A.mcode
, Ast_c.field
) matcher
649 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
651 val distrf_define_params
:
652 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
654 val distrf_enum_fields
:
655 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
657 val distrf_struct_fields
:
658 (A.meta_name
A.mcode
, B.field list
) matcher
661 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
664 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
667 (A.expression
, B.expression
) matcher
->
668 (A.expression
, B.expression
) matcher
671 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
674 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
677 A.keep_binding
-> A.inherited
->
678 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
679 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
680 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
682 val check_idconstraint
:
683 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
684 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
686 val check_constraints_ne
:
687 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
688 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
690 val all_bound
: A.meta_name list
-> (tin
-> bool)
692 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
693 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
694 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
698 (*****************************************************************************)
699 (* Functor code, "Cocci vs C" *)
700 (*****************************************************************************)
703 functor (X
: PARAM
) ->
706 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
709 let return = X.return
712 let (>||>) = X.(>||>)
713 let (>|+|>) = X.(>|+|>)
714 let (>&&>) = X.(>&&>)
716 let tokenf = X.tokenf
718 (* should be raise Impossible when called from transformation.ml *)
721 | PatternMode
-> fail
722 | TransformMode
-> raise Impossible
725 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
727 | (Some t1
, Some t2
) ->
728 f t1 t2
>>= (fun t1 t2
->
729 return (Some t1
, Some t2
)
731 | (None
, None
) -> return (None
, None
)
734 (* Dots are sometimes used as metavariables, since like metavariables they
735 can match other things. But they no longer have the same type. Perhaps these
736 functions could be avoided by introducing an appropriate level of polymorphism,
737 but I don't know how to declare polymorphism across functors *)
738 let dots2metavar (_
,info
,mcodekind,pos
) =
739 (("","..."),info
,mcodekind,pos
)
740 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
742 let satisfies_regexpconstraint c id
: bool =
744 A.IdRegExp
(_
,recompiled
) -> Str.string_match recompiled id
0
745 | A.IdNotRegExp
(_
,recompiled
) -> not
(Str.string_match recompiled id
0)
747 let satisfies_iconstraint c id
: bool =
750 let satisfies_econstraint c exp
: bool =
751 let warning s
= pr2_once
("WARNING: "^s
); false in
752 match Ast_c.unwrap_expr exp
with
753 Ast_c.Ident
(name
) ->
755 Ast_c.RegularName rname
->
756 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
757 | Ast_c.CppConcatenatedName _
->
759 "Unable to apply a constraint on a CppConcatenatedName identifier!"
760 | Ast_c.CppVariadicName _
->
762 "Unable to apply a constraint on a CppVariadicName identifier!"
763 | Ast_c.CppIdentBuilder _
->
765 "Unable to apply a constraint on a CppIdentBuilder identifier!")
766 | Ast_c.Constant cst
->
768 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
769 | Ast_c.MultiString strlist
->
770 warning "Unable to apply a constraint on an multistring constant!"
771 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
772 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
773 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
774 | _
-> warning "Unable to apply a constraint on an expression!"
777 (* ------------------------------------------------------------------------- *)
778 (* This has to be up here to allow adequate polymorphism *)
780 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
781 match_metalist rebuild_metalist mktermval special_cases
782 element distrf get_iis
= fun eas ebs
->
783 let rec loop = function
784 [], [] -> return ([], [])
785 | [], eb
::ebs
-> fail
787 X.all_bound
(A.get_inherited ea
) >&&>
789 (match match_dots ea
, ebs
with
790 Some
(mcode
, optexpr
), ys
->
791 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
792 if optexpr
<> None
then failwith
"not handling when in a list";
794 (* '...' can take more or less the beginnings of the arguments *)
796 Common.zip
(Common.inits ys
) (Common.tails ys
) in
798 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
801 (* allow '...', and maybe its associated ',' to match nothing.
802 * for the associated ',' see below how we handle the EComma
807 if mcode_contain_plus (mcodekind mcode
)
810 "I have no token that I could accroche myself on"*)
811 else return (dots2metavar mcode
, [])
813 (* subtil: we dont want the '...' to match until the
814 * comma. cf -test pb_params_iso. We would get at
815 * "already tagged" error.
816 * this is because both f (... x, ...) and f (..., x, ...)
817 * would match a f(x,3) with our "optional-comma" strategy.
819 (match Common.last startxs
with
821 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
823 >>= (fun mcode startxs
->
824 let mcode = metavar2dots mcode in
825 loop (eas
, endxs
) >>= (fun eas endxs
->
827 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
835 (match match_comma ea
, ebs
with
836 | Some ia1
, Right ii
::ebs
->
838 (let ib1 = tuple_of_list1 ii
in
839 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
840 loop (eas
, ebs
) >>= (fun eas ebs
->
842 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
847 (* allow ',' to maching nothing. optional comma trick *)
849 (if mcode_contain_plus (mcodekind ia1
)
851 else loop (eas
, ebs
))
854 (match match_metalist ea
, ebs
with
855 Some
(ida
,leninfo
,keep
,inherited
), ys
->
857 Common.zip
(Common.inits ys
) (Common.tails ys
) in
859 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
864 if mcode_contain_plus (mcodekind ida
)
866 (* failwith "no token that I could accroche myself on" *)
869 (match Common.last startxs
with
876 let startxs'
= Ast_c.unsplit_comma
startxs in
877 let len = List.length
startxs'
in
880 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
881 let max_min _
= failwith
"no pos" in
882 X.envf lenkeep leninherited
883 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
886 then (function f
-> f
())
887 else (function f
-> fail)
888 | A.AnyListLen
-> function f
-> f
())
891 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
892 X.envf keep inherited
893 (ida
, mktermval
startxs'
, max_min)
896 then return (ida
, [])
897 else distrf ida
(Ast_c.split_comma
startxs'
))
898 >>= (fun ida
startxs ->
899 loop (eas
, endxs
) >>= (fun eas endxs
->
901 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
910 special_cases ea eas ebs
in
911 match try_matches with
916 element ea eb
>>= (fun ea eb
->
917 loop (eas
, ebs
) >>= (fun eas ebs
->
918 return (ea
::eas
, Left eb
::ebs
)))
919 | (Right y
)::ys
-> raise Impossible
923 (*---------------------------------------------------------------------------*)
935 (*---------------------------------------------------------------------------*)
936 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
938 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
940 X.all_bound
(A.get_inherited ea
) >&&>
941 let wa x
= A.rewrap ea x
in
942 match A.unwrap ea
, eb
with
944 (* general case: a MetaExpr can match everything *)
945 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
946 (((expr
, opttypb
), ii
) as expb
) ->
948 (* old: before have a MetaConst. Now we factorize and use 'form' to
949 * differentiate between different cases *)
950 let rec matches_id = function
951 B.Ident
(name
) -> true
952 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
955 match (form
,expr
) with
958 let rec matches = function
959 B.Constant
(c
) -> true
960 | B.Ident
(nameidb
) ->
961 let s = Ast_c.str_of_name nameidb
in
962 if s =~
"^[A-Z_][A-Z_0-9]*$"
964 pr2_once
("warning: " ^
s ^
" treated as a constant");
968 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
969 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
970 | B.SizeOfExpr
(exp
) -> true
971 | B.SizeOfType
(ty
) -> true
977 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
979 | (A.ID
,e
) -> matches_id e
in
983 (let (opttypb
,_testb
) = !opttypb
in
984 match opttypa
, opttypb
with
985 | None
, _
-> return ((),())
987 pr2_once
("Missing type information. Certainly a pb in " ^
988 "annotate_typer.ml");
991 | Some tas
, Some tb
->
992 tas
+> List.fold_left
(fun acc ta
->
993 acc
>|+|> compatible_type ta tb
) fail
996 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
997 match constraints
with
998 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
999 | Ast_cocci.NotIdCstrt cstrt
->
1000 X.check_idconstraint
satisfies_econstraint cstrt eb
1001 (fun () -> return (meta_expr_val [],()))
1002 | Ast_cocci.NotExpCstrt cstrts
->
1003 X.check_constraints_ne expression cstrts eb
1004 (fun () -> return (meta_expr_val [],()))
1005 | Ast_cocci.SubExpCstrt cstrts
->
1006 return (meta_expr_val cstrts
,()))
1010 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1011 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1013 X.distrf_e ida expb
>>=
1016 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1024 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1025 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1027 * but bug! because if have not tagged SP, then transform without doing
1028 * any checks. Hopefully now have tagged SP technique.
1033 * | A.Edots _, _ -> raise Impossible.
1035 * In fact now can also have the Edots inside normal expression, not
1036 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1038 | A.Edots
(mcode, None
), expb
->
1039 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1041 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1046 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1049 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1051 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1053 ((A.Ident ida
)) +> wa,
1054 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1060 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1062 (* todo?: handle some isomorphisms in int/float ? can have different
1063 * format : 1l can match a 1.
1065 * todo: normally string can contain some metavar too, so should
1066 * recurse on the string
1068 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1069 (* for everything except the String case where can have multi elems *)
1071 let ib1 = tuple_of_list1 ii
in
1072 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1074 ((A.Constant ia1
)) +> wa,
1075 ((B.Constant
(ib
), typ),[ib1])
1078 (match term ia1
, ib
with
1079 | A.Int x
, B.Int
(y
,_
) ->
1080 X.value_format_flag
(fun use_value_equivalence
->
1081 if use_value_equivalence
1091 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1093 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1096 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1099 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1101 ((A.Constant ia1
)) +> wa,
1102 ((B.Constant
(ib
), typ),[ib1])
1104 | _
-> fail (* multi string, not handled *)
1107 | _
, B.MultiString _
-> (* todo cocci? *) fail
1108 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1112 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1113 (* todo: do special case to allow IdMetaFunc, cos doing the
1114 * recursive call will be too late, match_ident will not have the
1115 * info whether it was a function. todo: but how detect when do
1116 * x.field = f; how know that f is a Func ? By having computed
1117 * some information before the matching!
1119 * Allow match with FunCall containing types. Now ast_cocci allow
1120 * type in parameter, and morover ast_cocci allow f(...) and those
1121 * ... could match type.
1123 let (ib1, ib2
) = tuple_of_list2 ii
in
1124 expression ea eb
>>= (fun ea eb
->
1125 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1126 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1127 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1128 let eas = redots
eas easundots
in
1130 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1131 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1137 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1138 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1139 let (opbi
) = tuple_of_list1 ii
in
1140 if equal_assignOp (term opa
) opb
1142 expression ea1 eb1
>>= (fun ea1 eb1
->
1143 expression ea2 eb2
>>= (fun ea2 eb2
->
1144 tokenf opa opbi
>>= (fun opa opbi
->
1146 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1147 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1151 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1152 let (ib1, ib2
) = tuple_of_list2 ii
in
1153 expression ea1 eb1
>>= (fun ea1 eb1
->
1154 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1155 expression ea3 eb3
>>= (fun ea3 eb3
->
1156 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1157 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1159 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1160 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1163 (* todo?: handle some isomorphisms here ? *)
1164 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1165 let opbi = tuple_of_list1 ii
in
1166 if equal_fixOp (term opa
) opb
1168 expression ea eb
>>= (fun ea eb
->
1169 tokenf opa
opbi >>= (fun opa
opbi ->
1171 ((A.Postfix
(ea
, opa
))) +> wa,
1172 ((B.Postfix
(eb
, opb
), typ),[opbi])
1177 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1178 let opbi = tuple_of_list1 ii
in
1179 if equal_fixOp (term opa
) opb
1181 expression ea eb
>>= (fun ea eb
->
1182 tokenf opa
opbi >>= (fun opa
opbi ->
1184 ((A.Infix
(ea
, opa
))) +> wa,
1185 ((B.Infix
(eb
, opb
), typ),[opbi])
1189 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1190 let opbi = tuple_of_list1 ii
in
1191 if equal_unaryOp (term opa
) opb
1193 expression ea eb
>>= (fun ea eb
->
1194 tokenf opa
opbi >>= (fun opa
opbi ->
1196 ((A.Unary
(ea
, opa
))) +> wa,
1197 ((B.Unary
(eb
, opb
), typ),[opbi])
1201 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1202 let opbi = tuple_of_list1 ii
in
1203 if equal_binaryOp (term opa
) opb
1205 expression ea1 eb1
>>= (fun ea1 eb1
->
1206 expression ea2 eb2
>>= (fun ea2 eb2
->
1207 tokenf opa
opbi >>= (fun opa
opbi ->
1209 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1210 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1214 | A.Nested
(ea1
, opa
, ea2
), eb
->
1216 expression ea1 eb
>|+|>
1218 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1219 when equal_binaryOp (term opa
) opb
->
1220 let opbi = tuple_of_list1 ii
in
1222 (expression ea1 eb1
>>= (fun ea1 eb1
->
1223 expression ea2 eb2
>>= (fun ea2 eb2
->
1224 tokenf opa
opbi >>= (fun opa
opbi ->
1226 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1227 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1230 (expression ea2 eb1
>>= (fun ea2 eb1
->
1231 expression ea1 eb2
>>= (fun ea1 eb2
->
1232 tokenf opa
opbi >>= (fun opa
opbi ->
1234 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1235 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1238 (loop eb1
>>= (fun ea1 eb1
->
1239 expression ea2 eb2
>>= (fun ea2 eb2
->
1240 tokenf opa
opbi >>= (fun opa
opbi ->
1242 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1243 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1246 (expression ea2 eb1
>>= (fun ea2 eb1
->
1247 loop eb2
>>= (fun ea1 eb2
->
1248 tokenf opa
opbi >>= (fun opa
opbi ->
1250 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1251 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1253 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1257 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1258 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1259 let (ib1, ib2
) = tuple_of_list2 ii
in
1260 expression ea1 eb1
>>= (fun ea1 eb1
->
1261 expression ea2 eb2
>>= (fun ea2 eb2
->
1262 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1263 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1265 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1266 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1269 (* todo?: handle some isomorphisms here ? *)
1270 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1271 let (ib1) = tuple_of_list1 ii
in
1272 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1273 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1274 expression ea eb
>>= (fun ea eb
->
1276 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1277 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1282 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1283 let (ib1) = tuple_of_list1 ii
in
1284 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1285 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1286 expression ea eb
>>= (fun ea eb
->
1288 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1289 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1293 (* todo?: handle some isomorphisms here ?
1294 * todo?: do some iso-by-absence on cast ?
1295 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1298 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1299 let (ib1, ib2
) = tuple_of_list2 ii
in
1300 fullType typa typb
>>= (fun typa typb
->
1301 expression ea eb
>>= (fun ea eb
->
1302 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1303 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1305 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1306 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1309 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1310 let ib1 = tuple_of_list1 ii
in
1311 expression ea eb
>>= (fun ea eb
->
1312 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1314 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1315 ((B.SizeOfExpr
(eb
), typ),[ib1])
1318 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1319 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1320 fullType typa typb
>>= (fun typa typb
->
1321 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1322 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1323 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1325 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1326 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1330 (* todo? iso ? allow all the combinations ? *)
1331 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1332 let (ib1, ib2
) = tuple_of_list2 ii
in
1333 expression ea eb
>>= (fun ea eb
->
1334 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1335 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1337 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1338 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1341 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1342 (match A.unwrap exps
with
1344 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1345 X.distrf_e
(dots2metavar starter
) eb
>>= (fun mcode eb
->
1348 (metavar2dots mcode,
1349 A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1355 "for nestexpr, only handling the case with dots and only one exp")
1357 | A.NestExpr _
, _
->
1358 failwith
"only handling multi and no when code in a nest expr"
1360 (* only in arg lists or in define body *)
1361 | A.TypeExp _
, _
-> fail
1363 (* only in arg lists *)
1364 | A.MetaExprList _
, _
1371 | A.DisjExpr
eas, eb
->
1372 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1374 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1375 failwith
"not handling Opt/Unique/Multi on expr"
1377 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1379 (* have not a counter part in coccinelle, for the moment *)
1380 | _
, ((B.Sequence _
,_
),_
)
1381 | _
, ((B.StatementExpr _
,_
),_
)
1382 | _
, ((B.Constructor _
,_
),_
)
1383 | _
, ((B.New _
,_
),_
)
1384 | _
, ((B.Delete _
,_
),_
)
1389 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1390 B.RecordPtAccess
(_
, _
)|
1391 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1392 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1393 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1394 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1395 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1403 (* ------------------------------------------------------------------------- *)
1404 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1405 fun infoidb ida idb
->
1407 | B.RegularName
(s, iis) ->
1408 let iis = tuple_of_list1
iis in
1409 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1412 (B.RegularName
(s, [iis]))
1414 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1416 (* This should be moved to the Id case of ident. Metavariables
1417 should be allowed to be bound to such variables. But doing so
1418 would require implementing an appropriate distr function *)
1421 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1422 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1423 let check_constraints constraints idb
=
1424 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1425 match constraints
with
1426 A.IdNoConstraint
-> return (meta_id_val [],())
1427 | A.IdNegIdSet
(str
,meta
) ->
1428 X.check_idconstraint
satisfies_iconstraint str idb
1429 (fun () -> return (meta_id_val meta
,()))
1430 | A.IdRegExpConstraint re
->
1431 X.check_idconstraint
satisfies_regexpconstraint re idb
1432 (fun () -> return (meta_id_val [],())) in
1433 X.all_bound
(A.get_inherited ida
) >&&>
1434 match A.unwrap ida
with
1436 if (term sa
) =$
= idb
then
1437 tokenf sa iib
>>= (fun sa iib
->
1439 ((A.Id sa
)) +> A.rewrap ida
,
1444 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1445 check_constraints constraints idb
>>=
1447 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1448 (* use drop_pos for ids so that the pos is not added a second time in
1449 the call to tokenf *)
1450 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1452 tokenf mida iib
>>= (fun mida iib
->
1454 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1459 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1461 check_constraints constraints idb
>>=
1463 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1464 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1466 tokenf mida iib
>>= (fun mida iib
->
1468 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1473 | LocalFunction
| Function
-> is_function()
1475 failwith
"MetaFunc, need more semantic info about id"
1476 (* the following implementation could possibly be useful, if one
1477 follows the convention that a macro is always in capital letters
1478 and that a macro is not a function.
1479 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1482 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1485 check_constraints constraints idb
>>=
1487 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1488 X.envf keep inherited
1489 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1491 tokenf mida iib
>>= (fun mida iib
->
1493 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1499 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1502 (* not clear why disj things are needed, after disjdistr? *)
1504 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1506 | A.OptIdent _
| A.UniqueIdent _
->
1507 failwith
"not handling Opt/Unique for ident"
1509 (* ------------------------------------------------------------------------- *)
1510 and (arguments
: sequence
->
1511 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1512 fun seqstyle eas ebs
->
1514 | Unordered
-> failwith
"not handling ooo"
1516 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1517 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1519 (* because '...' can match nothing, need to take care when have
1520 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1521 * f(1,2) for instance.
1522 * So I have added special cases such as (if startxs = []) and code
1523 * in the Ecomma matching rule.
1525 * old: Must do some try, for instance when f(...,X,Y,...) have to
1526 * test the transfo for all the combinaitions and if multiple transfo
1527 * possible ? pb ? => the type is to return a expression option ? use
1528 * some combinators to help ?
1529 * update: with the tag-SP approach, no more a problem.
1532 and arguments_bis
= fun eas ebs
->
1534 match A.unwrap ea
with
1535 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1537 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1538 let match_comma ea
=
1539 match A.unwrap ea
with
1540 A.EComma ia1
-> Some ia1
1542 let build_comma ia1
= A.EComma ia1
in
1543 let match_metalist ea
=
1544 match A.unwrap ea
with
1545 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1546 Some
(ida
,leninfo
,keep
,inherited
)
1548 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1549 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1550 let mktermval v
= Ast_c.MetaExprListVal v
in
1551 let special_cases ea
eas ebs
= None
in
1552 list_matcher match_dots build_dots match_comma build_comma
1553 match_metalist build_metalist mktermval
1554 special_cases argument
X.distrf_args
1555 Lib_parsing_c.ii_of_args
eas ebs
1557 and argument arga argb
=
1558 X.all_bound
(A.get_inherited arga
) >&&>
1559 match A.unwrap arga
, argb
with
1561 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1562 if b
|| sopt
<> None
1564 (* failwith "the argument have a storage and ast_cocci does not have"*)
1567 (* b = false and sopt = None *)
1568 fullType tya tyb
>>= (fun tya tyb
->
1570 (A.TypeExp tya
) +> A.rewrap arga
,
1571 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1576 | A.TypeExp tya
, _
-> fail
1577 | _
, Right
(B.ArgType _
) -> fail
1579 expression arga argb
>>= (fun arga argb
->
1580 return (arga
, Left argb
)
1582 | _
, Right
(B.ArgAction y
) -> fail
1585 (* ------------------------------------------------------------------------- *)
1586 (* todo? facto code with argument ? *)
1587 and (parameters
: sequence
->
1588 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1590 fun seqstyle eas ebs
->
1592 | Unordered
-> failwith
"not handling ooo"
1594 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1595 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1599 and parameters_bis
eas ebs
=
1601 match A.unwrap ea
with
1602 A.Pdots
(mcode) -> Some
(mcode, None
)
1604 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1605 let match_comma ea
=
1606 match A.unwrap ea
with
1607 A.PComma ia1
-> Some ia1
1609 let build_comma ia1
= A.PComma ia1
in
1610 let match_metalist ea
=
1611 match A.unwrap ea
with
1612 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1613 Some
(ida
,leninfo
,keep
,inherited
)
1615 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1616 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1617 let mktermval v
= Ast_c.MetaParamListVal v
in
1618 let special_cases ea
eas ebs
=
1619 (* a case where one smpl parameter matches a list of C parameters *)
1620 match A.unwrap ea
,ebs
with
1621 A.VoidParam ta
, ys
->
1623 (match eas, ebs
with
1625 let {B.p_register
=(hasreg
,iihasreg
);
1627 p_type
=tb
; } = eb
in
1629 if idbopt
=*= None
&& not hasreg
1632 | (qub
, (B.BaseType
B.Void
,_
)) ->
1633 fullType ta tb
>>= (fun ta tb
->
1635 [(A.VoidParam ta
) +> A.rewrap ea
],
1636 [Left
{B.p_register
=(hasreg
, iihasreg
);
1644 list_matcher match_dots build_dots match_comma build_comma
1645 match_metalist build_metalist mktermval
1646 special_cases parameter
X.distrf_params
1647 Lib_parsing_c.ii_of_params
eas ebs
1650 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1651 match hasreg, idb, ii_b_s with
1652 | false, Some s, [i1] -> Left (s, [], i1)
1653 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1654 | _, None, ii -> Right ii
1655 | _ -> raise Impossible
1659 and parameter
= fun parama paramb
->
1660 match A.unwrap parama
, paramb
with
1661 A.MetaParam
(ida
,keep
,inherited
), eb
->
1662 (* todo: use quaopt, hasreg ? *)
1664 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1665 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1666 X.distrf_param ida eb
1667 ) >>= (fun ida eb
->
1668 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1669 | A.Param
(typa
, idaopt
), eb
->
1670 let {B.p_register
= (hasreg
,iihasreg
);
1671 p_namei
= nameidbopt
;
1672 p_type
= typb
;} = paramb
in
1674 fullType typa typb
>>= (fun typa typb
->
1675 match idaopt
, nameidbopt
with
1676 | Some ida
, Some nameidb
->
1677 (* todo: if minus on ida, should also minus the iihasreg ? *)
1678 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1680 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1681 {B.p_register
= (hasreg
, iihasreg
);
1682 p_namei
= Some
(nameidb
);
1688 A.Param
(typa
, None
)+> A.rewrap parama
,
1689 {B.p_register
=(hasreg
,iihasreg
);
1693 (* why handle this case ? because of transform_proto ? we may not
1694 * have an ident in the proto.
1695 * If have some plus on ida ? do nothing about ida ?
1697 (* not anymore !!! now that julia is handling the proto.
1698 | _, Right iihasreg ->
1701 ((hasreg, None, typb), iihasreg)
1705 | Some _
, None
-> fail
1706 | None
, Some _
-> fail)
1707 | (A.OptParam _
| A.UniqueParam _
), _
->
1708 failwith
"not handling Opt/Unique for Param"
1709 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1712 (* ------------------------------------------------------------------------- *)
1713 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1714 fun (mckstart
, allminus
, decla
) declb
->
1715 X.all_bound
(A.get_inherited decla
) >&&>
1716 match A.unwrap decla
, declb
with
1718 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1719 * de toutes les declarations qui sont au debut d'un fonction et
1720 * commencer le reste du match au premier statement. Alors, ca matche
1721 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1722 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1724 * When the SP want to remove the whole function, the minus is not
1725 * on the MetaDecl but on the MetaRuleElem. So there should
1726 * be no transform of MetaDecl, just matching are allowed.
1729 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1731 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1732 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1733 X.distrf_decl ida declb
1734 ) >>= (fun ida declb
->
1735 return ((mckstart
, allminus
,
1736 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1738 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1739 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1740 (fun decla
(var
,iiptvirgb
,iisto
)->
1741 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1743 (mckstart
, allminus
, decla
),
1744 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1747 | _
, (B.DeclList
(xs
, ((iiptvirgb
::iifakestart
::iisto
) as ii
))) ->
1749 let rec loop n
= function
1751 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1753 let rec repln n vl cur
= function
1756 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1757 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1759 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1760 (* consider all possible matches *)
1761 acc
>||> (function tin
-> (
1762 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1763 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1764 (fun decla
(var
, iiptvirgb
, iisto
) ->
1766 (mckstart
, allminus
, decla
),
1767 (* adjust the variable that was chosen *)
1768 (B.DeclList
(repln n var
0 xs
,
1769 iiptvirgb
::iifakestart
::iisto
))
1774 "More than one variable in the declaration, and so it cannot be transformed. Check that there is no transformation on the type or the ;"
1776 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1777 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1779 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1780 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1781 | _
-> raise Impossible
1784 then minusize_list iistob
1785 else return ((), iistob
)
1786 ) >>= (fun () iistob
->
1788 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1789 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1790 tokenf lpa lpb
>>= (fun lpa lpb
->
1791 tokenf rpa rpb
>>= (fun rpa rpb
->
1792 tokenf enda iiendb
>>= (fun enda iiendb
->
1793 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1794 let eas = redots
eas easundots
in
1797 (mckstart
, allminus
,
1798 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1799 (B.MacroDecl
((sb
,ebs
),
1800 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1803 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1806 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1807 X.all_bound
(A.get_inherited decla
) >&&>
1808 match A.unwrap decla
, declb
with
1810 (* kind of typedef iso, we must unfold, it's for the case
1811 * T { }; that we want to match against typedef struct { } xx_t;
1814 | A.TyDecl
(tya0
, ptvirga
),
1815 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1817 B.v_storage
= (B.StoTypedef
, inl
);
1820 B.v_type_bis
= typb0bis
;
1823 (match A.unwrap tya0
, typb0
with
1824 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1826 (match A.unwrap tya1
, typb1
with
1827 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1828 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1830 let (iisub
, iisbopt
, lbb
, rbb
) =
1833 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1834 (iisub
, [], lbb
, rbb
)
1837 "warning: both a typedef (%s) and struct name introduction (%s)"
1838 (Ast_c.str_of_name nameidb
) s
1840 pr2 "warning: I will consider only the typedef";
1841 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1842 (iisub
, [iisb
], lbb
, rbb
)
1845 structdef_to_struct_name
1846 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1849 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1850 (Lib_parsing_c.al_type
structnameb))), [])
1853 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1854 tokenf lba lbb
>>= (fun lba lbb
->
1855 tokenf rba rbb
>>= (fun rba rbb
->
1856 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1857 let declsa = redots
declsa undeclsa
in
1859 (match A.unwrap tya2
with
1860 | A.Type
(cv3
, tya3
) ->
1861 (match A.unwrap tya3
with
1862 | A.MetaType
(ida
,keep
, inherited
) ->
1864 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1866 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1867 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1870 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1871 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1872 let typb0 = ((qu
, il
), typb1) in
1874 match fake_typeb with
1875 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1878 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1879 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1881 B.v_storage
= (B.StoTypedef
, inl
);
1884 B.v_type_bis
= typb0bis
;
1886 iivirg
),iiptvirgb
,iistob
)
1888 | _
-> raise Impossible
1891 (* do we need EnumName here too? *)
1892 | A.StructUnionName
(sua
, sa
) ->
1893 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1895 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1897 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1899 match structnameb with
1900 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1902 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1903 [iisub
;iisbopt
;lbb
;rbb
] in
1904 let typb0 = ((qu
, il
), typb1) in
1907 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1908 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1910 B.v_storage
= (B.StoTypedef
, inl
);
1913 B.v_type_bis
= typb0bis
;
1915 iivirg
),iiptvirgb
,iistob
)
1917 | _
-> raise Impossible
1919 | _
-> raise Impossible
1928 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1929 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1932 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1933 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1938 (* could handle iso here but handled in standard.iso *)
1939 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1940 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1945 B.v_type_bis
= typbbis
;
1947 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1948 fullType typa typb
>>= (fun typa typb
->
1949 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1950 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1951 (fun stoa
(stob
, iistob
) ->
1953 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1954 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1959 B.v_type_bis
= typbbis
;
1964 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1965 ({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1970 B.v_type_bis
= typbbis
;
1973 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1974 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1975 fullType typa typb
>>= (fun typa typb
->
1976 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1977 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1978 (fun stoa
(stob
, iistob
) ->
1979 initialiser inia inib
>>= (fun inia inib
->
1981 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1982 (({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
1987 B.v_type_bis
= typbbis
;
1992 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1993 ({B.v_namei
= Some
(nameidb
, B.ConstrInit _
);
1998 B.v_type_bis
= typbbis
;
2000 -> fail (* C++ constructor declaration not supported in SmPL *)
2002 (* do iso-by-absence here ? allow typedecl and var ? *)
2003 | A.TyDecl
(typa
, ptvirga
),
2004 ({B.v_namei
= None
; B.v_type
= typb
;
2008 B.v_type_bis
= typbbis
;
2011 if stob
=*= (B.NoSto
, false)
2013 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2014 fullType typa typb
>>= (fun typa typb
->
2016 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2017 (({B.v_namei
= None
;
2022 B.v_type_bis
= typbbis
;
2023 }, iivirg
), iiptvirgb
, iistob
)
2028 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2029 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2031 B.v_storage
= (B.StoTypedef
,inline
);
2034 B.v_type_bis
= typbbis
;
2037 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2038 fullType typa typb
>>= (fun typa typb
->
2041 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2042 return (stoa
, [iitypedef
])
2044 | _
-> error iistob
"weird, have both typedef and inline or nothing";
2045 ) >>= (fun stoa iistob
->
2046 (match A.unwrap ida
with
2047 | A.MetaType
(_
,_
,_
) ->
2050 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2052 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2053 match fake_typeb with
2054 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2055 return (ida
, nameidb
)
2056 | _
-> raise Impossible
2061 | B.RegularName
(sb
, iidb
) ->
2062 let iidb1 = tuple_of_list1 iidb
in
2066 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2068 (A.TypeName sa
) +> A.rewrap ida
,
2069 B.RegularName
(sb
, [iidb1])
2073 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2077 | _
-> raise Impossible
2079 ) >>= (fun ida nameidb
->
2081 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2082 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2084 B.v_storage
= (B.StoTypedef
,inline
);
2087 B.v_type_bis
= typbbis
;
2095 | _
, ({B.v_namei
= None
;}, _
) ->
2096 (* old: failwith "no variable in this declaration, weird" *)
2101 | A.DisjDecl declas
, declb
->
2102 declas
+> List.fold_left
(fun acc decla
->
2104 (* (declaration (mckstart, allminus, decla) declb) *)
2105 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2110 (* only in struct type decls *)
2111 | A.Ddots
(dots
,whencode
), _
->
2114 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2115 failwith
"not handling Opt/Unique Decl"
2117 | _
, ({B.v_namei
=Some _
}, _
) ->
2123 (* ------------------------------------------------------------------------- *)
2125 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2126 X.all_bound
(A.get_inherited ia
) >&&>
2127 match (A.unwrap ia
,ib
) with
2129 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2131 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2132 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2134 X.distrf_ini ida ib
>>= (fun ida ib
->
2136 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2141 | (A.InitExpr expa
, ib
) ->
2142 (match A.unwrap expa
, ib
with
2143 | A.Edots
(mcode, None
), ib
->
2144 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2147 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2152 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2154 | _
, (B.InitExpr expb
, ii
) ->
2156 expression expa expb
>>= (fun expa expb
->
2158 (A.InitExpr expa
) +> A.rewrap ia
,
2159 (B.InitExpr expb
, ii
)
2164 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2166 | ib1::ib2
::iicommaopt
->
2167 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2168 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2169 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2170 (fun iasundots
(ibs
,iicommaopt
) ->
2172 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2173 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2176 | _
-> raise Impossible
2179 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2181 | ib1::ib2
::iicommaopt
->
2182 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2183 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2184 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2185 (fun ias
(ibs
,iicommaopt
) ->
2187 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2188 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2191 | _
-> raise Impossible
2194 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2195 (B.InitList ibs
, _ii
)) ->
2196 failwith
"TODO: not handling whencode in initialisers"
2199 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2200 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2202 let iieq = tuple_of_list1 ii2
in
2204 tokenf ia2
iieq >>= (fun ia2
iieq ->
2205 designators designatorsa designatorsb
>>=
2206 (fun designatorsa designatorsb
->
2207 initialiser inia inib
>>= (fun inia inib
->
2209 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2210 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2216 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2219 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2220 initialiser inia inib
>>= (fun inia inib
->
2221 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2223 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2224 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2231 | A.IComma
(comma
), _
->
2234 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2235 failwith
"not handling Opt/Unique on initialisers"
2237 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2238 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2240 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2243 and designators dla dlb
=
2244 match (dla
,dlb
) with
2245 ([],[]) -> return ([], [])
2246 | ([],_
) | (_
,[]) -> fail
2247 | (da
::dla
,db
::dlb
) ->
2248 designator da db
>>= (fun da db
->
2249 designators dla dlb
>>= (fun dla dlb
->
2250 return (da
::dla
, db
::dlb
)))
2252 and designator da db
=
2254 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2256 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2257 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2258 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2260 A.DesignatorField
(ia1
, ida
),
2261 (B.DesignatorField idb
, [iidot
;iidb
])
2264 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2266 let (ib1, ib2
) = tuple_of_list2 ii1
in
2267 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2268 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2269 expression ea eb
>>= (fun ea eb
->
2271 A.DesignatorIndex
(ia1
,ea
,ia2
),
2272 (B.DesignatorIndex eb
, [ib1;ib2
])
2275 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2276 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2278 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2279 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2280 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2281 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2282 expression e1a e1b
>>= (fun e1a e1b
->
2283 expression e2a e2b
>>= (fun e2a e2b
->
2285 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2286 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2288 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2291 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2292 let ias_unsplit = unsplit_icomma ias
in
2293 let ibs_split = resplit_initialiser ibs iicomma
in
2295 if need_unordered_initialisers ibs
2296 then initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2297 (fun ias_unsplit ibs_split ->
2299 split_icomma ias_unsplit,
2300 unsplit_initialiser ibs_split))
2303 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2304 (* this doesn't check need_unordered_initialisers because ... can be
2305 implemented as ordered, even if it matches unordered initializers *)
2306 let ibs = resplit_initialiser ibs iicomma
in
2309 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2310 initialisers_ordered2 ias
ibs >>=
2311 (fun ias
ibs_split ->
2313 match List.rev
ibs_split with
2314 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2315 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2317 return (ias
, (ibs,iicomma
)))
2319 and initialisers_ordered2
= fun ias
ibs ->
2321 match A.unwrap ea
with
2322 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2324 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2325 let match_comma ea
=
2326 match A.unwrap ea
with
2327 A.IComma ia1
-> Some ia1
2329 let build_comma ia1
= A.IComma ia1
in
2330 let match_metalist ea
=
2331 match A.unwrap ea
with
2332 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) ->
2333 Some
(ida
,leninfo
,keep
,inherited
)
2335 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2336 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) in
2337 let mktermval v
= Ast_c.MetaInitListVal v
in
2338 let special_cases ea
eas ebs
= None
in
2339 let no_ii x
= failwith
"not possible" in
2340 list_matcher match_dots build_dots match_comma build_comma
2341 match_metalist build_metalist mktermval
2342 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2344 and initialisers_unordered2
= fun allminus ias
ibs ->
2349 let rec loop = function
2350 [] -> return ([],[])
2351 | (ib
,comma
)::ibs ->
2352 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2353 tokenf minusizer comma
>>= (fun _ comma
->
2354 loop ibs >>= (fun l
ibs ->
2355 return(l
,(ib
,comma
)::ibs)))) in
2357 else return ([], ys
)
2359 let permut = Common.uncons_permut_lazy ys
in
2360 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2362 (initialiser_comma x e
2364 let rest = Lazy.force
rest in
2365 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2368 Common.insert_elem_pos
(e
, pos
) rest
2372 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2373 match A.unwrap xcomma
with
2375 tokenf commax commay
>>= (fun commax commay
->
2376 initialiser x y
>>= (fun x y
->
2378 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2380 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2382 (* ------------------------------------------------------------------------- *)
2383 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2386 match A.unwrap ea
with
2387 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2389 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2390 let match_comma ea
= None
in
2391 let build_comma ia1
= failwith
"not possible" in
2392 let match_metalist ea
=
2393 match A.unwrap ea
with
2394 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) ->
2395 Some
(ida
,leninfo
,keep
,inherited
)
2397 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2398 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) in
2400 (* drop empty ii information, because nothing between elements *)
2401 let v = List.map
Ast_c.unwrap
v in
2402 Ast_c.MetaFieldListVal
v in
2403 let special_cases ea
eas ebs
= None
in
2404 let no_ii x
= failwith
"not possible" in
2405 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2406 let unmake_ebs ebs
=
2407 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2408 let distrf mcode startxs =
2409 let startxs = unmake_ebs startxs in
2410 X.distrf_struct_fields
mcode startxs >>=
2411 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2412 list_matcher match_dots build_dots match_comma build_comma
2413 match_metalist build_metalist mktermval
2414 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2415 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2417 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2419 match A.unwrap fa
,fb
with
2420 | A.MetaField
(ida
,keep
,inherited
), _
->
2422 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2423 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2424 X.distrf_field ida fb
2425 ) >>= (fun ida fb
->
2426 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2428 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2430 let iiptvirgb = tuple_of_list1 iiptvirg
in
2432 (match onefield_multivars
with
2433 | [] -> raise Impossible
2434 | [onevar
,iivirg
] ->
2435 assert (null iivirg
);
2437 | B.BitField
(sopt
, typb
, _
, expr
) ->
2438 pr2_once
"warning: bitfield not handled by ast_cocci";
2440 | B.Simple
(None
, typb
) ->
2441 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2443 | B.Simple
(Some nameidb
, typb
) ->
2445 (* build a declaration from a struct field *)
2446 let allminus = false in
2448 let stob = B.NoSto
, false in
2450 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2453 B.v_local
= Ast_c.NotLocalDecl
;
2454 B.v_attr
= Ast_c.noattr
;
2455 B.v_type_bis
= ref None
;
2456 (* the struct field should also get expanded ? no it's not
2457 * important here, we will rematch very soon *)
2461 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2462 (fun fa
(var
,iiptvirgb,iisto) ->
2465 | ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2470 let onevar = B.Simple
(Some nameidb
, typb
) in
2474 ((B.DeclarationField
2475 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2478 | _
-> raise Impossible
2483 pr2_once
"PB: More that one variable in decl. Have to split";
2486 | _
,B.EmptyField _iifield
->
2489 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2491 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2493 | _
,B.CppDirectiveStruct directive
-> fail
2494 | _
,B.IfdefStruct directive
-> fail
2497 and enum_fields
= fun eas ebs
->
2499 match A.unwrap ea
with
2500 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2502 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2503 let match_comma ea
=
2504 match A.unwrap ea
with
2505 A.EComma ia1
-> Some ia1
2507 let build_comma ia1
= A.EComma ia1
in
2508 let match_metalist ea
= None
in
2509 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2510 let mktermval v = failwith
"not possible" in
2511 let special_cases ea
eas ebs
= None
in
2512 list_matcher match_dots build_dots match_comma build_comma
2513 match_metalist build_metalist mktermval
2514 special_cases enum_field
X.distrf_enum_fields
2515 Lib_parsing_c.ii_of_enum_fields
eas ebs
2517 and enum_field ida idb
=
2518 X.all_bound
(A.get_inherited ida
) >&&>
2519 match A.unwrap ida
, idb
with
2520 A.Ident
(id
),(nameidb
,None
) ->
2521 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2522 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2523 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2524 (match A.unwrap ea1
with
2526 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2527 expression ea2 eb2
>>= (fun ea2 eb2
->
2528 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2530 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2532 (nameidb
,Some
(opbi,eb2
))))))
2533 | _
-> failwith
"not possible")
2534 | _
-> failwith
"not possible"
2536 (* ------------------------------------------------------------------------- *)
2537 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2539 X.optional_qualifier_flag
(fun optional_qualifier
->
2540 X.all_bound
(A.get_inherited typa
) >&&>
2541 match A.unwrap typa
, typb
with
2542 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2544 if qu
.B.const
&& qu
.B.volatile
2547 ("warning: the type is both const & volatile but cocci " ^
2548 "does not handle that");
2550 (* Drop out the const/volatile part that has been matched.
2551 * This is because a SP can contain const T v; in which case
2552 * later in match_t_t when we encounter a T, we must not add in
2553 * the environment the whole type.
2558 (* "iso-by-absence" *)
2561 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2563 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2567 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2568 | false, false -> do_stuff ()
2569 | false, true -> fail
2570 | true, false -> do_stuff ()
2573 then pr2_once
"USING optional_qualifier builtin isomorphism";
2579 (* todo: can be __const__ ? can be const & volatile so
2580 * should filter instead ?
2582 (match term x
, il
with
2583 | A.Const
, [i1
] when qu
.B.const
->
2585 tokenf x i1
>>= (fun x i1
->
2586 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2588 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2592 | A.Volatile
, [i1
] when qu
.B.volatile
->
2593 tokenf x i1
>>= (fun x i1
->
2594 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2596 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2604 | A.DisjType typas
, typb
->
2606 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2608 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2609 -> failwith
"not handling Opt/Unique on type"
2614 * Why not (A.typeC, Ast_c.typeC) matcher ?
2615 * because when there is MetaType, we want that T record the whole type,
2616 * including the qualifier, and so this type (and the new_il function in
2617 * preceding function).
2620 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2622 X.all_bound
(A.get_inherited ta
) >&&>
2623 match A.unwrap ta
, tb
with
2626 | A.MetaType
(ida
,keep
, inherited
), typb
->
2628 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2629 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2630 X.distrf_type ida typb
>>= (fun ida typb
->
2632 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2636 | unwrap
, (qub
, typb
) ->
2637 typeC ta typb
>>= (fun ta typb
->
2638 return (ta
, (qub
, typb
))
2641 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2642 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2643 * And even if in baseb we have a Signed Int, that does not mean
2644 * that ii is of length 2, cos Signed is the default, so if in signa
2645 * we have Signed explicitely ? we cant "accrocher" this mcode to
2646 * something :( So for the moment when there is signed in cocci,
2647 * we force that there is a signed in c too (done in pattern.ml).
2649 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2652 (* handle some iso on type ? (cf complex C rule for possible implicit
2654 match basea
, baseb
with
2655 | A.VoidType
, B.Void
2656 | A.FloatType
, B.FloatType
(B.CFloat
)
2657 | A.DoubleType
, B.FloatType
(B.CDouble
)
2658 | A.SizeType
, B.SizeType
2659 | A.SSizeType
, B.SSizeType
2660 | A.PtrDiffType
,B.PtrDiffType
->
2661 assert (signaopt
=*= None
);
2662 let stringa = tuple_of_list1 stringsa
in
2663 let (ibaseb
) = tuple_of_list1 ii
in
2664 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2666 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2667 (B.BaseType baseb
, [ibaseb
])
2670 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2671 let stringa = tuple_of_list1 stringsa
in
2672 let ibaseb = tuple_of_list1 ii
in
2673 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2675 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2676 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2679 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2680 let stringa = tuple_of_list1 stringsa
in
2681 let ibaseb = tuple_of_list1 iibaseb
in
2682 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2683 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2685 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2686 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2689 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2690 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2691 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2692 let stringa = tuple_of_list1 stringsa
in
2695 (* iso-by-presence ? *)
2696 (* when unsigned int in SP, allow have just unsigned in C ? *)
2697 if mcode_contain_plus (mcodekind stringa)
2701 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2703 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2704 (B.BaseType
(baseb
), iisignbopt
++ [])
2710 "warning: long int or short int not handled by ast_cocci";
2714 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2715 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2717 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2718 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2720 | _
-> raise Impossible
2725 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2726 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2728 [ibase1b
;ibase2b
] ->
2729 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2730 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2731 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2733 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2734 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2736 | [] -> fail (* should something be done in this case? *)
2737 | _
-> raise Impossible
)
2740 | _
, B.FloatType
B.CLongDouble
2743 "warning: long double not handled by ast_cocci";
2746 | _
, (B.Void
|B.FloatType _
|B.IntType _
2747 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2749 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2750 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2751 * And even if in baseb we have a Signed Int, that does not mean
2752 * that ii is of length 2, cos Signed is the default, so if in signa
2753 * we have Signed explicitely ? we cant "accrocher" this mcode to
2754 * something :( So for the moment when there is signed in cocci,
2755 * we force that there is a signed in c too (done in pattern.ml).
2757 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2759 let match_to_type rebaseb
=
2760 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2761 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2762 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2763 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2764 (match A.unwrap
fta,tb
with
2765 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2767 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2768 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2770 | _
-> failwith
"not possible"))) in
2772 (* handle some iso on type ? (cf complex C rule for possible implicit
2775 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2776 match_to_type (B.IntType
B.CChar
)
2778 | B.IntType
(B.Si
(_
, ty
)) ->
2780 | [] -> fail (* metavariable has to match something *)
2782 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2786 | (B.Void
|B.FloatType _
|B.IntType _
2787 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2789 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2791 match A.unwrap ta
, tb
with
2792 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2793 simulate_signed ta basea stringsa None tb baseb ii
2794 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2795 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2796 (match A.unwrap basea
with
2797 A.BaseType
(basea1
,strings1
) ->
2798 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2799 (function (strings1
, Some signaopt
) ->
2802 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2803 | _
-> failwith
"not possible")
2804 | A.MetaType
(ida
,keep
,inherited
) ->
2805 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2806 (function (basea
, Some signaopt
) ->
2807 A.SignedT
(signaopt
,Some basea
)
2808 | _
-> failwith
"not possible")
2809 | _
-> failwith
"not possible")
2810 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2811 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2812 (match iibaseb
, baseb
with
2813 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2814 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2816 | None
-> raise Impossible
2819 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2820 (B.BaseType baseb
, iisignbopt
)
2828 (* todo? iso with array *)
2829 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2830 let (ibmult
) = tuple_of_list1 ii
in
2831 fullType typa typb
>>= (fun typa typb
->
2832 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2834 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2835 (B.Pointer typb
, [ibmult
])
2838 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2839 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2841 let (lpb
, rpb
) = tuple_of_list2 ii
in
2845 ("Not handling well variable length arguments func. "^
2846 "You have been warned");
2847 tokenf lpa lpb
>>= (fun lpa lpb
->
2848 tokenf rpa rpb
>>= (fun rpa rpb
->
2849 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2850 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2851 (fun paramsaundots paramsb
->
2852 let paramsa = redots
paramsa paramsaundots
in
2854 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2855 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2863 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2864 (B.ParenType t1
, ii
) ->
2865 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2866 let (qu1b
, t1b
) = t1
in
2868 | B.Pointer t2
, ii
->
2869 let (starb
) = tuple_of_list1 ii
in
2870 let (qu2b
, t2b
) = t2
in
2872 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2873 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2878 ("Not handling well variable length arguments func. "^
2879 "You have been warned");
2881 fullType tya tyb
>>= (fun tya tyb
->
2882 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2883 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2884 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2885 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2886 tokenf stara starb
>>= (fun stara starb
->
2887 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2888 (fun paramsaundots paramsb
->
2889 let paramsa = redots
paramsa paramsaundots
in
2893 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2898 (B.Pointer
t2, [starb
]))
2902 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2904 (B.ParenType
t1, [lp1b
;rp1b
])
2917 (* todo: handle the iso on optionnal size specifification ? *)
2918 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2919 let (ib1, ib2
) = tuple_of_list2 ii
in
2920 fullType typa typb
>>= (fun typa typb
->
2921 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2922 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2923 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2925 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2926 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2930 (* todo: could also match a Struct that has provided a name *)
2931 (* This is for the case where the SmPL code contains "struct x", without
2932 a definition. In this case, the name field is always present.
2933 This case is also called from the case for A.StructUnionDef when
2934 a name is present in the C code. *)
2935 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2936 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2937 let (ib1, ib2
) = tuple_of_list2 ii
in
2938 if equal_structUnion (term sua
) sub
2940 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2941 tokenf sua
ib1 >>= (fun sua
ib1 ->
2943 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2944 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2949 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2950 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2952 let (ii_sub_sb
, lbb
, rbb
) =
2954 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2955 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2956 | _
-> error ii
"list of length 3 or 4 expected" in
2959 match (sbopt
,ii_sub_sb
) with
2960 (None
,Common.Left iisub
) ->
2961 (* the following doesn't reconstruct the complete SP code, just
2962 the part that matched *)
2964 match A.unwrap
s with
2966 (match A.unwrap ty
with
2967 A.StructUnionName
(sua
, None
) ->
2968 (match (term sua
, sub
) with
2970 | (A.Union
,B.Union
) -> return ((),())
2973 tokenf sua iisub
>>= (fun sua iisub
->
2976 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2978 return (ty,[iisub
])))
2980 | A.DisjType
(disjs
) ->
2982 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2986 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2988 (* build a StructUnionName from a StructUnion *)
2989 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2991 fullType
ty fake_su >>= (fun ty fake_su ->
2993 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2994 return (ty, [iisub
; iisb
])
2995 | _
-> raise Impossible
)
2999 >>= (fun ty ii_sub_sb
->
3001 tokenf lba lbb
>>= (fun lba lbb
->
3002 tokenf rba rbb
>>= (fun rba rbb
->
3003 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
3004 let declsa = redots
declsa undeclsa
in
3007 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
3008 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
3012 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
3013 * uint in the C code. But some CEs consists in renaming some types,
3014 * so we don't want apply isomorphisms every time.
3016 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3020 | B.RegularName
(sb
, iidb
) ->
3021 let iidb1 = tuple_of_list1 iidb
in
3025 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3027 (A.TypeName sa
) +> A.rewrap ta
,
3028 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3032 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3037 | _
, (B.NoType
, ii
) -> fail
3038 | _
, (B.TypeOfExpr e
, ii
) -> fail
3039 | _
, (B.TypeOfType e
, ii
) -> fail
3041 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3042 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3043 let (ib1,ib2
) = tuple_of_list2 ii
in
3044 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3045 tokenf en
ib1 >>= (fun en
ib1 ->
3047 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3048 (B.EnumName nameb
, [ib1;ib2
])
3051 | A.EnumDef
(ty, lba
, idsa
, rba
),
3052 (B.Enum
(sbopt
, idsb
), ii
) ->
3054 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3056 [iisub
; lbb
; rbb
; comma_opt
] ->
3057 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3058 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3059 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3060 | _
-> error ii
"list of length 4 or 5 expected" in
3063 match (sbopt
,ii_sub_sb
) with
3064 (None
,Common.Left iisub
) ->
3065 (* the following doesn't reconstruct the complete SP code, just
3066 the part that matched *)
3068 match A.unwrap
s with
3070 (match A.unwrap
ty with
3071 A.EnumName
(sua
, None
) ->
3072 tokenf sua iisub
>>= (fun sua iisub
->
3074 A.Type
(None
,A.EnumName
(sua
, None
) +> A.rewrap
ty)
3076 return (ty,[iisub
]))
3078 | A.DisjType
(disjs
) ->
3080 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3084 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3086 (* build an EnumName from an Enum *)
3087 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3089 fullType
ty fake_su >>= (fun ty fake_su ->
3091 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3092 return (ty, [iisub
; iisb
])
3093 | _
-> raise Impossible
)
3097 >>= (fun ty ii_sub_sb
->
3099 tokenf lba lbb
>>= (fun lba lbb
->
3100 tokenf rba rbb
>>= (fun rba rbb
->
3101 let idsb = resplit_initialiser idsb [comma_opt
] in
3105 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3107 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3108 let idsa = redots
idsa unidsa
in
3110 match List.rev
idsb with
3111 (Right comma
)::rest ->
3112 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3113 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3116 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3117 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3121 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3124 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3125 B.StructUnion
(_
, _
, _
) |
3126 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3132 (* todo: iso on sign, if not mentioned then free. tochange?
3133 * but that require to know if signed int because explicit
3134 * signed int, or because implicit signed int.
3137 and sign signa signb
=
3138 match signa
, signb
with
3139 | None
, None
-> return (None
, [])
3140 | Some signa
, Some
(signb
, ib
) ->
3141 if equal_sign (term signa
) signb
3142 then tokenf signa ib
>>= (fun signa ib
->
3143 return (Some signa
, [ib
])
3149 and minusize_list iixs
=
3150 iixs
+> List.fold_left
(fun acc ii
->
3151 acc
>>= (fun xs ys
->
3152 tokenf minusizer ii
>>= (fun minus ii
->
3153 return (minus
::xs
, ii
::ys
)
3154 ))) (return ([],[]))
3155 >>= (fun _xsminys ys
->
3156 return ((), List.rev ys
)
3159 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3160 (* "iso-by-absence" for storage, and return type. *)
3161 X.optional_storage_flag
(fun optional_storage
->
3162 match stoa
, stob with
3163 | None
, (stobis
, inline
) ->
3167 minusize_list iistob
>>= (fun () iistob
->
3168 return (None
, (stob, iistob
))
3170 else return (None
, (stob, iistob
))
3173 (match optional_storage
, stobis
with
3174 | false, B.NoSto
-> do_minus ()
3176 | true, B.NoSto
-> do_minus ()
3179 then pr2_once
"USING optional_storage builtin isomorphism";
3183 | Some x
, ((stobis
, inline
)) ->
3184 if equal_storage (term x
) stobis
3186 let rec loop acc
= function
3189 let str = B.str_of_info i1
in
3191 "static" | "extern" | "auto" | "register" ->
3192 (* not very elegant, but tokenf doesn't know what token to
3194 tokenf x i1
>>= (fun x i1
->
3195 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3196 return (Some x
, ((stobis
, inline
), rebuilt)))
3197 | _
-> loop (i1
::acc
) iistob
) in
3202 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3203 (* "iso-by-absence" for storage, and return type. *)
3204 X.optional_storage_flag
(fun optional_storage
->
3205 match inla
, stob with
3206 | None
, (stobis
, inline
) ->
3210 minusize_list iistob
>>= (fun () iistob
->
3211 return (None
, (stob, iistob
))
3213 else return (None
, (stob, iistob
))
3222 then pr2_once
"USING optional_storage builtin isomorphism";
3225 else fail (* inline not in SP and present in C code *)
3228 | Some x
, ((stobis
, inline
)) ->
3231 let rec loop acc
= function
3234 let str = B.str_of_info i1
in
3237 (* not very elegant, but tokenf doesn't know what token to
3239 tokenf x i1
>>= (fun x i1
->
3240 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3241 return (Some x
, ((stobis
, inline
), rebuilt)))
3242 | _
-> loop (i1
::acc
) iistob
) in
3244 else fail (* SP has inline, but the C code does not *)
3247 and fullType_optional_allminus
allminus tya retb
=
3252 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3256 else return (None
, retb
)
3258 fullType tya retb
>>= (fun tya retb
->
3259 return (Some tya
, retb
)
3264 (*---------------------------------------------------------------------------*)
3266 and compatible_base_type a signa b
=
3267 let ok = return ((),()) in
3270 | Type_cocci.VoidType
, B.Void
3271 | Type_cocci.SizeType
, B.SizeType
3272 | Type_cocci.SSizeType
, B.SSizeType
3273 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3274 assert (signa
=*= None
);
3276 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3278 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3279 compatible_sign signa signb
3280 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3281 compatible_sign signa signb
3282 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3283 compatible_sign signa signb
3284 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3285 compatible_sign signa signb
3286 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3287 pr2_once
"no longlong in cocci";
3289 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3290 assert (signa
=*= None
);
3292 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3293 assert (signa
=*= None
);
3295 | _
, B.FloatType
B.CLongDouble
->
3296 pr2_once
"no longdouble in cocci";
3298 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3300 | _
, (B.Void
|B.FloatType _
|B.IntType _
3301 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3303 and compatible_base_type_meta a signa qua b ii
local =
3305 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3306 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3307 compatible_sign signa signb
>>= fun _ _
->
3308 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3309 compatible_type a
newb
3310 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3311 compatible_sign signa signb
>>= fun _ _
->
3313 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3314 compatible_type a
newb
3315 | _
, B.FloatType
B.CLongDouble
->
3316 pr2_once
"no longdouble in cocci";
3319 | _
, (B.Void
|B.FloatType _
|B.IntType _
3320 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3323 and compatible_type a
(b
,local) =
3324 let ok = return ((),()) in
3326 let rec loop = function
3327 | _
, (qua
, (B.NoType
, _
)) ->
3328 failwith
"compatible_type: matching with NoType"
3329 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3330 compatible_base_type a None b
3332 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3333 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3335 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3337 Type_cocci.BaseType
ty ->
3338 compatible_base_type
ty (Some signa
) b
3339 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3340 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3341 | _
-> failwith
"not possible")
3343 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3345 | Type_cocci.FunctionPointer a
, _
->
3347 "TODO: function pointer type doesn't store enough information to determine compatability"
3348 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3349 (* no size info for cocci *)
3351 | Type_cocci.StructUnionName
(sua
, name
),
3352 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3353 if equal_structUnion_type_cocci sua sub
3354 then structure_type_name name sb ii
3356 | Type_cocci.EnumName
(name
),
3357 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3358 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3359 let sb = Ast_c.str_of_name namesb
in
3364 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3365 if (fst qub
).B.const
&& (fst qub
).B.volatile
3368 pr2_once
("warning: the type is both const & volatile but cocci " ^
3369 "does not handle that");
3375 | Type_cocci.Const
-> (fst qub
).B.const
3376 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3378 then loop (a
,(Ast_c.nQ
, b
))
3381 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3383 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3384 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3388 (* subtil: must be after the MetaType case *)
3389 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3390 (* kind of typedef iso *)
3393 (* for metavariables of type expression *^* *)
3394 | Type_cocci.Unknown
, _
-> ok
3399 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3400 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3407 B.StructUnionName
(_
, _
)|
3409 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3414 and structure_type_name nm
sb ii
=
3416 Type_cocci.NoName
-> ok
3417 | Type_cocci.Name sa
->
3421 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3422 (* degenerate version of MetaId, no transformation possible *)
3423 let (ib1, ib2
) = tuple_of_list2 ii
in
3424 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3425 let mida = A.make_mcode ida
in
3426 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3432 and compatible_sign signa signb
=
3433 let ok = return ((),()) in
3434 match signa
, signb
with
3436 | Some
Type_cocci.Signed
, B.Signed
3437 | Some
Type_cocci.Unsigned
, B.UnSigned
3442 and equal_structUnion_type_cocci a b
=
3444 | Type_cocci.Struct
, B.Struct
-> true
3445 | Type_cocci.Union
, B.Union
-> true
3446 | _
, (B.Struct
| B.Union
) -> false
3450 (*---------------------------------------------------------------------------*)
3451 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3453 let rec aux_inc (ass
, bss
) passed
=
3457 let passed = List.rev
passed in
3459 (match before_after
, !h_rel_pos
with
3460 | IncludeNothing
, _
-> true
3461 | IncludeMcodeBefore
, Some x
->
3462 List.mem
passed (x
.Ast_c.first_of
)
3464 | IncludeMcodeAfter
, Some x
->
3465 List.mem
passed (x
.Ast_c.last_of
)
3467 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3471 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3472 | _
-> failwith
"IncDots not in last place or other pb"
3477 | A.Local ass
, B.Local bss
->
3478 aux_inc (ass
, bss
) []
3479 | A.NonLocal ass
, B.NonLocal bss
->
3480 aux_inc (ass
, bss
) []
3485 (*---------------------------------------------------------------------------*)
3487 and (define_params
: sequence
->
3488 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3489 fun seqstyle eas ebs
->
3491 | Unordered
-> failwith
"not handling ooo"
3493 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3494 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3497 (* todo? facto code with argument and parameters ? *)
3498 and define_paramsbis
= fun eas ebs
->
3500 match A.unwrap ea
with
3501 A.DPdots
(mcode) -> Some
(mcode, None
)
3503 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3504 let match_comma ea
=
3505 match A.unwrap ea
with
3506 A.DPComma ia1
-> Some ia1
3508 let build_comma ia1
= A.DPComma ia1
in
3509 let match_metalist ea
= None
in
3510 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3511 let mktermval v = failwith
"not possible" in
3512 let special_cases ea
eas ebs
= None
in
3513 let no_ii x
= failwith
"not possible" in
3514 list_matcher match_dots build_dots match_comma build_comma
3515 match_metalist build_metalist mktermval
3516 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3518 and define_parameter
= fun parama paramb
->
3519 match A.unwrap parama
, paramb
with
3520 A.DParam ida
, (idb
, ii
) ->
3521 let ib1 = tuple_of_list1 ii
in
3522 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3523 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3524 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3525 failwith
"handling Opt/Unique for define parameters"
3526 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3529 (*****************************************************************************)
3531 (*****************************************************************************)
3533 (* no global solution for positions here, because for a statement metavariable
3534 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3536 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3539 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3541 X.all_bound
(A.get_inherited re
) >&&>
3544 match A.unwrap re
, F.unwrap node
with
3546 (* note: the order of the clauses is important. *)
3548 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3550 (* the metaRuleElem contains just '-' information. We dont need to add
3551 * stuff in the environment. If we need stuff in environment, because
3552 * there is a + S somewhere, then this will be done via MetaStmt, not
3554 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3557 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3558 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3559 (match unwrap_node
with
3561 | F.TrueNode
| F.FalseNode
| F.AfterNode
3562 | F.LoopFallThroughNode
| F.FallThroughNode
3564 if X.mode
=*= PatternMode
3567 if mcode_contain_plus (mcodekind mcode)
3568 then failwith
"try add stuff on fake node"
3569 (* minusize or contextize a fake node is ok *)
3572 | F.EndStatement None
->
3573 if X.mode
=*= PatternMode
then return default
3575 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3576 if mcode_contain_plus (mcodekind mcode)
3578 let fake_info = Ast_c.fakeInfo() in
3579 distrf distrf_node (mcodekind mcode)
3580 (F.EndStatement (Some fake_info))
3581 else return unwrap_node
3585 | F.EndStatement
(Some i1
) ->
3586 tokenf mcode i1
>>= (fun mcode i1
->
3588 A.MetaRuleElem
(mcode,keep
, inherited
),
3589 F.EndStatement
(Some i1
)
3593 if X.mode
=*= PatternMode
then return default
3594 else failwith
"a MetaRuleElem can't transform a headfunc"
3596 if X.mode
=*= PatternMode
then return default
3598 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3600 A.MetaRuleElem
(mcode,keep
, inherited
),
3606 (* rene cant have found that a state containing a fake/exit/... should be
3608 * TODO: and F.Fake ?
3610 | _
, F.EndStatement _
| _
, F.CaseNode _
3611 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3612 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3613 | _
, F.InLoopNode
-> fail2()
3615 (* really ? diff between pattern.ml and transformation.ml *)
3616 | _
, F.Fake
-> fail2()
3619 (* cas general: a Meta can match everything. It matches only
3620 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3621 * So can't have been called in transform.
3623 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3625 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3626 (* todo: should not happen in transform mode *)
3628 (match Control_flow_c.extract_fullstatement node
with
3631 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3632 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3634 (* no need tag ida, we can't be called in transform-mode *)
3636 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3644 | A.MetaStmtList _
, _
->
3645 failwith
"not handling MetaStmtList"
3647 | A.TopExp ea
, F.DefineExpr eb
->
3648 expression ea eb
>>= (fun ea eb
->
3654 | A.TopExp ea
, F.DefineType eb
->
3655 (match A.unwrap ea
with
3657 fullType ft eb
>>= (fun ft eb
->
3659 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3666 (* It is important to put this case before the one that fails because
3667 * of the lack of the counter part of a C construct in SmPL (for instance
3668 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3669 * yet certain constructs, those constructs may contain expression
3670 * that we still want and can transform.
3673 | A.Exp exp
, nodeb
->
3675 (* kind of iso, initialisation vs affectation *)
3677 match A.unwrap exp
, nodeb
with
3678 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3679 initialisation_to_affectation decl
+> F.rewrap node
3684 (* Now keep fullstatement inside the control flow node,
3685 * so that can then get in a MetaStmtVar the fullstatement to later
3686 * pp back when the S is in a +. But that means that
3687 * Exp will match an Ifnode even if there is no such exp
3688 * inside the condition of the Ifnode (because the exp may
3689 * be deeper, in the then branch). So have to not visit
3690 * all inside a node anymore.
3692 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3693 * fois le fullstatement et le partialstatement et appeler le
3694 * visiteur que sur le partialstatement.
3697 match Ast_cocci.get_pos re
with
3698 | None
-> expression
3702 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3703 let keep = Type_cocci.Unitary
in
3704 let inherited = false in
3705 let max_min _
= failwith
"no pos" in
3706 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3712 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3720 X.cocciTy fullType
ty node >>= (fun ty node ->
3727 | A.TopInit init
, nodeb
->
3728 X.cocciInit initialiser init
node >>= (fun init
node ->
3736 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3737 F.FunHeader
({B.f_name
= nameidb
;
3738 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3742 f_old_c_style
= oldstyle
;
3747 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3750 (* fninfoa records the order in which the SP specified the various
3751 information, but this isn't taken into account in the matching.
3752 Could this be a problem for transformation? *)
3755 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3756 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3758 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3759 with [A.FType
(t
)] -> Some t
| _
-> None
in
3762 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3763 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3765 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3766 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3769 | ioparenb
::icparenb
::iifakestart
::iistob
->
3771 (* maybe important to put ident as the first tokens to transform.
3772 * It's related to transform_proto. So don't change order
3775 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3776 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3777 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3778 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3779 parameters
(seqstyle paramsa)
3780 (A.undots
paramsa) paramsb
>>=
3781 (fun paramsaundots paramsb
->
3782 let paramsa = redots
paramsa paramsaundots
in
3783 inline_optional_allminus
allminus
3784 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3785 storage_optional_allminus
allminus
3786 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3791 ("Not handling well variable length arguments func. "^
3792 "You have been warned");
3794 then minusize_list iidotsb
3795 else return ((),iidotsb
)
3796 ) >>= (fun () iidotsb
->
3798 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3801 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3802 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3803 (match tya with Some t
-> [A.FType t
] | None
-> [])
3808 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3810 F.FunHeader
({B.f_name
= nameidb
;
3811 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3815 f_old_c_style
= oldstyle
; (* TODO *)
3817 ioparenb
::icparenb
::iifakestart
::iistob
)
3820 | _
-> raise Impossible
3828 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3829 declaration
(mckstart
,allminus,decla
) declb
>>=
3830 (fun (mckstart
,allminus,decla
) declb
->
3832 A.Decl
(mckstart
,allminus,decla
),
3837 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3838 tokenf mcode i1
>>= (fun mcode i1
->
3841 F.SeqStart
(st
, level
, i1
)
3844 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3845 tokenf mcode i1
>>= (fun mcode i1
->
3848 F.SeqEnd
(level
, i1
)
3851 | A.ExprStatement
(Some ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3852 let ib1 = tuple_of_list1 ii
in
3853 expression ea eb
>>= (fun ea eb
->
3854 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3856 A.ExprStatement
(Some ea
, ia1
),
3857 F.ExprStatement
(st
, (Some eb
, [ib1]))
3861 | A.ExprStatement
(None
, ia1
), F.ExprStatement
(st
, (None
, ii
)) ->
3862 let ib1 = tuple_of_list1 ii
in
3863 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3865 A.ExprStatement
(None
, ia1
),
3866 F.ExprStatement
(st
, (None
, [ib1]))
3871 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3872 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3873 expression ea eb
>>= (fun ea eb
->
3874 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3875 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3876 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3878 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3879 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3882 | A.Else ia
, F.Else ib
->
3883 tokenf ia ib
>>= (fun ia ib
->
3884 return (A.Else ia
, F.Else ib
)
3887 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3888 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3889 expression ea eb
>>= (fun ea eb
->
3890 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3891 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3892 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3894 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3895 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3898 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3899 tokenf ia ib
>>= (fun ia ib
->
3904 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3905 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3906 expression ea eb
>>= (fun ea eb
->
3907 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3908 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3909 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3910 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3912 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3913 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3915 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3917 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3919 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3920 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3921 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3922 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3923 let eas = redots
eas easundots
in
3925 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3926 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3931 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3932 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3934 assert (null ib4vide
);
3935 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3936 let ib3 = tuple_of_list1 ib3s
in
3937 let ib4 = tuple_of_list1 ib4s
in
3939 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3940 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3941 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3942 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3943 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3944 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3945 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3946 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3948 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3949 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3955 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3956 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3957 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3958 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3959 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3960 expression ea eb
>>= (fun ea eb
->
3962 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3963 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3966 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3967 let (ib1, ib2
) = tuple_of_list2 ii
in
3968 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3969 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3972 F.Break
(st
, ((),[ib1;ib2
]))
3975 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3976 let (ib1, ib2
) = tuple_of_list2 ii
in
3977 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3978 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3980 A.Continue
(ia1
, ia2
),
3981 F.Continue
(st
, ((),[ib1;ib2
]))
3984 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3985 let (ib1, ib2
) = tuple_of_list2 ii
in
3986 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3987 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3989 A.Return
(ia1
, ia2
),
3990 F.Return
(st
, ((),[ib1;ib2
]))
3993 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3994 let (ib1, ib2
) = tuple_of_list2 ii
in
3995 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3996 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3997 expression ea eb
>>= (fun ea eb
->
3999 A.ReturnExpr
(ia1
, ea
, ia2
),
4000 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
4005 | A.Include
(incla
,filea
),
4006 F.Include
{B.i_include
= (fileb
, ii
);
4007 B.i_rel_pos
= h_rel_pos
;
4008 B.i_is_in_ifdef
= inifdef
;
4011 assert (copt
=*= None
);
4013 let include_requirment =
4014 match mcodekind incla
, mcodekind filea
with
4015 | A.CONTEXT
(_
, A.BEFORE _
), _
->
4017 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
4023 let (inclb
, iifileb
) = tuple_of_list2 ii
in
4024 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
4026 tokenf incla inclb
>>= (fun incla inclb
->
4027 tokenf filea iifileb
>>= (fun filea iifileb
->
4029 A.Include
(incla
, filea
),
4030 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
4031 B.i_rel_pos
= h_rel_pos
;
4032 B.i_is_in_ifdef
= inifdef
;
4038 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
4039 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4040 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4041 tokenf undefa defineb
>>= (fun undefa defineb
->
4043 A.Undef
(undefa
,ida
),
4044 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
4049 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4050 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4051 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4052 tokenf definea defineb
>>= (fun definea defineb
->
4053 (match A.unwrap params
, defkind
with
4054 | A.NoParams
, B.DefineVar
->
4056 A.NoParams
+> A.rewrap params
,
4059 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4060 let (lpb
, rpb
) = tuple_of_list2 ii
in
4061 tokenf lpa lpb
>>= (fun lpa lpb
->
4062 tokenf rpa rpb
>>= (fun rpa rpb
->
4064 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4065 (fun easundots ebs
->
4066 let eas = redots
eas easundots
in
4068 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4069 B.DefineFunc
(ebs
,[lpb
;rpb
])
4073 ) >>= (fun params defkind
->
4075 A.DefineHeader
(definea
, ida
, params
),
4076 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4081 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4082 let (ib1, ib2
) = tuple_of_list2 ii
in
4083 tokenf def
ib1 >>= (fun def
ib1 ->
4084 tokenf colon ib2
>>= (fun colon ib2
->
4086 A.Default
(def
,colon
),
4087 F.Default
(st
, ((),[ib1;ib2
]))
4092 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4093 let (ib1, ib2
) = tuple_of_list2 ii
in
4094 tokenf case
ib1 >>= (fun case
ib1 ->
4095 expression ea eb
>>= (fun ea eb
->
4096 tokenf colon ib2
>>= (fun colon ib2
->
4098 A.Case
(case
,ea
,colon
),
4099 F.Case
(st
, (eb
,[ib1;ib2
]))
4102 (* only occurs in the predicates generated by asttomember *)
4103 | A.DisjRuleElem
eas, _
->
4105 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4106 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4108 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4110 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4111 let (ib2
) = tuple_of_list1 ii
in
4112 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4113 tokenf dd ib2
>>= (fun dd ib2
->
4116 F.Label
(st
,nameb
, ((),[ib2
]))
4119 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4120 let (ib1,ib3) = tuple_of_list2 ii
in
4121 tokenf goto
ib1 >>= (fun goto
ib1 ->
4122 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4123 tokenf sem
ib3 >>= (fun sem
ib3 ->
4125 A.Goto
(goto
,id
,sem
),
4126 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4129 (* have not a counter part in coccinelle, for the moment *)
4130 (* todo?: print a warning at least ? *)
4136 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4140 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4143 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4144 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4145 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4146 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4147 F.MacroIterHeader
(_
, _
)|
4148 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4149 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4150 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4151 F.Decl _
|F.FunHeader _
)