1 (* Copyright (C) 2006, 2007, 2008 Yoann Padioleau
3 * This program is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU General Public License (GPL)
5 * version 2 as published by the Free Software Foundation.
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * file license.txt for more details.
12 * This file was part of Coccinelle.
20 module F
= Control_flow_c
22 module Flag
= Flag_matcher
24 (*****************************************************************************)
26 (*****************************************************************************)
28 (*****************************************************************************)
30 (*****************************************************************************)
32 type sequence
= Ordered
| Unordered
35 match A.unwrap eas
with
37 | A.CIRCLES _
-> Unordered
38 | A.STARS _
-> failwith
"not handling stars"
40 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
42 match A.unwrap eas
with
43 | A.DOTS _
-> A.DOTS easundots
44 | A.CIRCLES _
-> A.CIRCLES easundots
45 | A.STARS _
-> A.STARS easundots
49 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
51 ibs
+> List.exists
(fun (ib
, icomma
) ->
52 match B.unwrap ib
with
62 (* For the #include <linux/...> in the .cocci, need to find where is
63 * the '+' attached to this element, to later find the first concrete
64 * #include <linux/xxx.h> or last one in the serie of #includes in the
67 type include_requirement
=
74 (* todo? put in semantic_c.ml *)
77 | LocalFunction
(* entails Function *)
81 let term mc
= A.unwrap_mcode mc
82 let mcodekind mc
= A.get_mcodekind mc
85 let mcode_contain_plus = function
86 | A.CONTEXT
(_
,A.NOTHING
) -> false
88 | A.MINUS
(_
,[]) -> false
89 | A.MINUS
(_
,x
::xs
) -> true
90 | A.PLUS
-> raise Impossible
92 let mcode_simple_minus = function
93 | A.MINUS
(_
,[]) -> true
97 (* In transformation.ml sometime I build some mcodekind myself and
98 * julia has put None for the pos. But there is no possible raise
99 * NoMatch in those cases because it is for the minusall trick or for
100 * the distribute, so either have to build those pos, in fact a range,
101 * because for the distribute have to erase a fullType with one
102 * mcodekind, or add an argument to tag_with_mck such as "safe" that
103 * don't do the check_pos. Hence this DontCarePos constructor. *)
107 {A.line
= 0; column
=0; A.strbef
=[]; A.straft
=[];},
108 (A.MINUS
(A.DontCarePos
, [])),
111 let generalize_mcode ia
=
112 let (s1
, i
, mck
, pos
) = ia
in
115 | A.PLUS
-> raise Impossible
116 | A.CONTEXT
(A.NoPos
,x
) ->
117 A.CONTEXT
(A.DontCarePos
,x
)
118 | A.MINUS
(A.NoPos
,x
) ->
119 A.MINUS
(A.DontCarePos
,x
)
121 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
122 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
)
126 (s1
, i
, new_mck, pos
)
130 (*---------------------------------------------------------------------------*)
132 (* 0x0 is equivalent to 0, value format isomorphism *)
133 let equal_c_int s1 s2
=
135 int_of_string s1
= int_of_string s2
136 with Failure
("int_of_string") ->
141 (*---------------------------------------------------------------------------*)
142 (* Normally A should reuse some types of Ast_c, so those
143 * functions should not exist.
145 * update: but now Ast_c depends on A, so can't make too
146 * A depends on Ast_c, so have to stay with those equal_xxx
150 let equal_unaryOp a b
=
152 | A.GetRef
, B.GetRef
-> true
153 | A.DeRef
, B.DeRef
-> true
154 | A.UnPlus
, B.UnPlus
-> true
155 | A.UnMinus
, B.UnMinus
-> true
156 | A.Tilde
, B.Tilde
-> true
157 | A.Not
, B.Not
-> true
158 | _
, B.GetRefLabel
-> false (* todo cocci? *)
159 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
163 let equal_arithOp a b
=
165 | A.Plus
, B.Plus
-> true
166 | A.Minus
, B.Minus
-> true
167 | A.Mul
, B.Mul
-> true
168 | A.Div
, B.Div
-> true
169 | A.Mod
, B.Mod
-> true
170 | A.DecLeft
, B.DecLeft
-> true
171 | A.DecRight
, B.DecRight
-> true
172 | A.And
, B.And
-> true
173 | A.Or
, B.Or
-> true
174 | A.Xor
, B.Xor
-> true
175 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
178 let equal_logicalOp a b
=
180 | A.Inf
, B.Inf
-> true
181 | A.Sup
, B.Sup
-> true
182 | A.InfEq
, B.InfEq
-> true
183 | A.SupEq
, B.SupEq
-> true
184 | A.Eq
, B.Eq
-> true
185 | A.NotEq
, B.NotEq
-> true
186 | A.AndLog
, B.AndLog
-> true
187 | A.OrLog
, B.OrLog
-> true
188 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
191 let equal_assignOp a b
=
193 | A.SimpleAssign
, B.SimpleAssign
-> true
194 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
195 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
197 let equal_fixOp a b
=
199 | A.Dec
, B.Dec
-> true
200 | A.Inc
, B.Inc
-> true
201 | _
, (B.Inc
|B.Dec
) -> false
203 let equal_binaryOp a b
=
205 | A.Arith a
, B.Arith b
-> equal_arithOp a b
206 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
207 | _
, (B.Logical _
| B.Arith _
) -> false
209 let equal_structUnion a b
=
211 | A.Struct
, B.Struct
-> true
212 | A.Union
, B.Union
-> true
213 | _
, (B.Struct
|B.Union
) -> false
217 | A.Signed
, B.Signed
-> true
218 | A.Unsigned
, B.UnSigned
-> true
219 | _
, (B.UnSigned
|B.Signed
) -> false
221 let equal_storage a b
=
223 | A.Static
, B.Sto
B.Static
224 | A.Auto
, B.Sto
B.Auto
225 | A.Register
, B.Sto
B.Register
226 | A.Extern
, B.Sto
B.Extern
228 | _
, (B.NoSto
| B.StoTypedef
) -> false
229 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
232 (*---------------------------------------------------------------------------*)
234 let equal_metavarval valu valu'
=
235 match valu
, valu'
with
236 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
237 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
238 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
239 (* do something more ? *)
242 (* al_expr before comparing !!! and accept when they match.
243 * Note that here we have Astc._expression, so it is a match
244 * modulo isomorphism (there is no metavariable involved here,
245 * just isomorphisms). => TODO call isomorphism_c_c instead of
246 * =*=. Maybe would be easier to transform ast_c in ast_cocci
247 * and call the iso engine of julia. *)
248 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
249 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
250 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
251 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
253 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
254 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
255 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
256 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
259 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
261 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
262 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
263 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
264 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
266 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
267 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
269 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
271 (function (fla
,cea
,posa1
,posa2
) ->
273 (function (flb
,ceb
,posb1
,posb2
) ->
274 fla
= flb
&& cea
= ceb
&&
275 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
279 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
281 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
282 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
287 (*---------------------------------------------------------------------------*)
288 (* could put in ast_c.ml, next to the split/unsplit_comma *)
289 let split_signb_baseb_ii (baseb
, ii
) =
290 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
291 match baseb
, iis with
293 | B.Void
, ["void",i1
] -> None
, [i1
]
295 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
296 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
297 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
299 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
302 | B.IntType
(B.Si
(sign
, base
)), xs
->
303 (match sign
, base
, xs
with
304 | B.Signed
, B.CChar2
, ["signed",i1
;"char",i2
] ->
305 Some
(B.Signed
, i1
), [i2
]
306 | B.UnSigned
, B.CChar2
, ["unsigned",i1
;"char",i2
] ->
307 Some
(B.UnSigned
, i1
), [i2
]
309 | B.Signed
, B.CShort
, ["short",i1
] ->
311 | B.Signed
, B.CShort
, ["signed",i1
;"short",i2
] ->
312 Some
(B.Signed
, i1
), [i2
]
313 | B.UnSigned
, B.CShort
, ["unsigned",i1
;"short",i2
] ->
314 Some
(B.UnSigned
, i1
), [i2
]
315 | B.Signed
, B.CShort
, ["short",i1
;"int",i2
] ->
318 | B.Signed
, B.CInt
, ["int",i1
] ->
320 | B.Signed
, B.CInt
, ["signed",i1
;"int",i2
] ->
321 Some
(B.Signed
, i1
), [i2
]
322 | B.UnSigned
, B.CInt
, ["unsigned",i1
;"int",i2
] ->
323 Some
(B.UnSigned
, i1
), [i2
]
325 | B.Signed
, B.CInt
, ["signed",i1
;] ->
326 Some
(B.Signed
, i1
), []
327 | B.UnSigned
, B.CInt
, ["unsigned",i1
;] ->
328 Some
(B.UnSigned
, i1
), []
330 | B.Signed
, B.CLong
, ["long",i1
] ->
332 | B.Signed
, B.CLong
, ["long",i1
;"int",i2
] ->
334 | B.Signed
, B.CLong
, ["signed",i1
;"long",i2
] ->
335 Some
(B.Signed
, i1
), [i2
]
336 | B.UnSigned
, B.CLong
, ["unsigned",i1
;"long",i2
] ->
337 Some
(B.UnSigned
, i1
), [i2
]
339 | B.Signed
, B.CLongLong
, ["long",i1
;"long",i2
] -> None
, [i1
;i2
]
340 | B.Signed
, B.CLongLong
, ["signed",i1
;"long",i2
;"long",i3
] ->
341 Some
(B.Signed
, i1
), [i2
;i3
]
342 | B.UnSigned
, B.CLongLong
, ["unsigned",i1
;"long",i2
;"long",i3
] ->
343 Some
(B.UnSigned
, i1
), [i2
;i3
]
346 | B.UnSigned
, B.CShort
, ["unsigned",i1
;"short",i2
; "int", i3
] ->
347 Some
(B.UnSigned
, i1
), [i2
;i3
]
351 | _
-> failwith
"strange type1, maybe because of weird order"
353 | _
-> failwith
"strange type2, maybe because of weird order"
355 (*---------------------------------------------------------------------------*)
357 let rec unsplit_icomma xs
=
361 (match A.unwrap y
with
363 (x
, y
)::unsplit_icomma xs
364 | _
-> failwith
"wrong ast_cocci in initializer"
367 failwith
("wrong ast_cocci in initializer, should have pair " ^
372 let resplit_initialiser ibs iicomma
=
373 match iicomma
, ibs
with
376 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
378 failwith
"shouldn't have a iicomma"
379 | [iicomma
], x
::xs
->
380 let elems = List.map fst
(x
::xs
) in
381 let commas = List.map snd
(x
::xs
) +> List.flatten
in
382 let commas = commas @ [iicomma
] in
384 | _
-> raise Impossible
388 let rec split_icomma xs
=
391 | (x
,y
)::xs
-> x
::y
::split_icomma xs
393 let rec unsplit_initialiser ibs_unsplit
=
394 match ibs_unsplit
with
395 | [] -> [], [] (* empty iicomma *)
397 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
398 (x
, [])::xs
, lastcomma
400 and unsplit_initialiser_bis comma_before
= function
401 | [] -> [], [comma_before
]
403 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
404 (x
, [comma_before
])::xs
, lastcomma
409 (*---------------------------------------------------------------------------*)
410 (* coupling: same in type_annotater_c.ml *)
411 let structdef_to_struct_name ty
=
413 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
415 | Some s
, [i1
;i2
;i3
;i4
] ->
416 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
420 | x
-> raise Impossible
422 | _
-> raise Impossible
424 (*---------------------------------------------------------------------------*)
425 let initialisation_to_affectation decl
=
427 | B.MacroDecl _
-> F.Decl decl
428 | B.DeclList
(xs
, iis) ->
430 (* todo?: should not do that if the variable is an array cos
431 * will have x[] = , mais de toute facon ca sera pas un InitExp
434 | [] -> raise Impossible
436 let ({B.v_namei
= var
;
437 B.v_type
= returnType
;
438 B.v_storage
= storage
;
443 | Some
((s
, ini
), iis::iini
) ->
445 | Some
(B.InitExpr e
, ii_empty2
) ->
448 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
449 | Ast_c.LocalDecl
-> Ast_c.LocalVar
(iis.Ast_c.pinfo
) in
452 ref (Some
((Lib_parsing_c.al_type returnType
),local),
454 let id = (B.Ident s
, typ),[iis] in
456 ((B.Assignment
(id, B.SimpleAssign
, e
),
457 Ast_c.noType
()), iini
)
463 pr2_once
"TODO: initialisation_to_affectation for multi vars";
464 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
465 * the Sequence expression operator of C and make an
466 * ExprStatement from that.
475 (*****************************************************************************)
476 (* Functor parameter combinators *)
477 (*****************************************************************************)
479 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
481 * version0: was not tagging the SP, so just tag the C
483 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
484 * val return : 'b -> tin -> 'b tout
485 * val fail : tin -> 'b tout
487 * version1: now also tag the SP so return a ('a * 'b)
490 type mode
= PatternMode
| TransformMode
498 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
503 (tin
-> ('a
* 'b
) tout
) ->
504 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
505 (tin
-> ('c
* 'd
) tout
)
507 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
508 val fail
: tin
-> ('a
* 'b
) tout
520 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
522 val tokenf
: ('a
A.mcode
, B.info
) matcher
523 val tokenf_mck
: (A.mcodekind, B.info
) matcher
526 (A.meta_name
A.mcode
, B.expression
) matcher
528 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
530 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
532 (A.meta_name
A.mcode
,
533 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
535 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
537 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
539 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
541 val distrf_define_params
:
542 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
545 val distrf_struct_fields
:
546 (A.meta_name
A.mcode
, B.field list
) matcher
549 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
552 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
555 (A.expression
, B.expression
) matcher
->
556 (A.expression
, B.expression
) matcher
559 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
562 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
565 A.keep_binding
-> A.inherited
->
566 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
567 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
568 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
570 val check_constraints
:
571 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
572 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
574 val all_bound
: A.meta_name list
-> (tin
-> bool)
576 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
577 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
578 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
583 (*****************************************************************************)
584 (* Functor code, "Cocci vs C" *)
585 (*****************************************************************************)
588 functor (X
: PARAM
) ->
591 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
594 let return = X.return
597 let (>||>) = X.(>||>)
598 let (>|+|>) = X.(>|+|>)
599 let (>&&>) = X.(>&&>)
601 let tokenf = X.tokenf
603 (* should be raise Impossible when called from transformation.ml *)
606 | PatternMode
-> fail
607 | TransformMode
-> raise Impossible
610 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
612 | (Some t1
, Some t2
) ->
613 f t1 t2
>>= (fun t1 t2
->
614 return (Some t1
, Some t2
)
616 | (None
, None
) -> return (None
, None
)
619 (* Dots are sometimes used as metavariables, since like metavariables they
620 can match other things. But they no longer have the same type. Perhaps these
621 functions could be avoided by introducing an appropriate level of polymorphism,
622 but I don't know how to declare polymorphism across functors *)
623 let dots2metavar (_
,info
,mcodekind,pos
) = (("","..."),info
,mcodekind,pos
)
624 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
626 (*---------------------------------------------------------------------------*)
638 (*---------------------------------------------------------------------------*)
639 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
641 X.all_bound
(A.get_inherited ea
) >&&>
642 let wa x
= A.rewrap ea x
in
643 match A.unwrap ea
, eb
with
645 (* general case: a MetaExpr can match everything *)
646 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
647 (((expr
, opttypb
), ii
) as expb
) ->
649 (* old: before have a MetaConst. Now we factorize and use 'form' to
650 * differentiate between different cases *)
651 let rec matches_id = function
653 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
656 match (form
,expr
) with
659 let rec matches = function
660 B.Constant
(c
) -> true
661 | B.Ident idb
when idb
=~
"^[A-Z_][A-Z_0-9]*$" ->
662 pr2_once
("warning: I consider " ^ idb ^
" as a constant");
664 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
665 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
666 | B.SizeOfExpr
(exp
) -> true
667 | B.SizeOfType
(ty
) -> true
673 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
675 | (A.ID
,e
) -> matches_id e
in
679 (let (opttypb
,_testb
) = !opttypb
in
680 match opttypa
, opttypb
with
681 | None
, _
-> return ((),())
683 pr2_once
("Missing type information. Certainly a pb in " ^
684 "annotate_typer.ml");
687 | Some tas
, Some tb
->
688 tas
+> List.fold_left
(fun acc ta
->
689 acc
>|+|> compatible_type ta tb
) fail
692 X.check_constraints expression constraints eb
695 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
696 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
698 X.distrf_e ida expb
>>= (fun ida expb
->
700 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
708 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
709 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
711 * but bug! because if have not tagged SP, then transform without doing
712 * any checks. Hopefully now have tagged SP technique.
717 * | A.Edots _, _ -> raise Impossible.
719 * In fact now can also have the Edots inside normal expression, not
720 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
722 | A.Edots
(mcode
, None
), expb
->
723 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
725 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
730 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
733 | A.Ident ida
, ((B.Ident idb
, typ),ii
) ->
734 let ib1 = tuple_of_list1 ii
in
735 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
737 ((A.Ident ida
)) +> wa,
738 ((B.Ident idb
, typ),[ib1])
744 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
746 (* todo?: handle some isomorphisms in int/float ? can have different
747 * format : 1l can match a 1.
749 * todo: normally string can contain some metavar too, so should
750 * recurse on the string
752 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
753 (* for everything except the String case where can have multi elems *)
755 let ib1 = tuple_of_list1 ii
in
756 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
758 ((A.Constant ia1
)) +> wa,
759 ((B.Constant
(ib
), typ),[ib1])
762 (match term ia1
, ib
with
763 | A.Int x
, B.Int y
->
764 X.value_format_flag
(fun use_value_equivalence
->
765 if use_value_equivalence
775 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
777 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
780 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
783 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
785 ((A.Constant ia1
)) +> wa,
786 ((B.Constant
(ib
), typ),[ib1])
788 | _
-> fail (* multi string, not handled *)
791 | _
, B.MultiString
-> (* todo cocci? *) fail
792 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
796 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
797 (* todo: do special case to allow IdMetaFunc, cos doing the
798 * recursive call will be too late, match_ident will not have the
799 * info whether it was a function. todo: but how detect when do
800 * x.field = f; how know that f is a Func ? By having computed
801 * some information before the matching!
803 * Allow match with FunCall containing types. Now ast_cocci allow
804 * type in parameter, and morover ast_cocci allow f(...) and those
805 * ... could match type.
807 let (ib1, ib2
) = tuple_of_list2 ii
in
808 expression ea eb
>>= (fun ea eb
->
809 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
810 tokenf ia2 ib2
>>= (fun ia2 ib2
->
811 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
812 let eas = redots
eas easundots
in
814 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
815 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
821 | A.Assignment
(ea1
, opa
, ea2
, simple
),
822 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
823 let (opbi
) = tuple_of_list1 ii
in
824 if equal_assignOp (term opa
) opb
826 expression ea1 eb1
>>= (fun ea1 eb1
->
827 expression ea2 eb2
>>= (fun ea2 eb2
->
828 tokenf opa opbi
>>= (fun opa opbi
->
830 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
831 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
835 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
836 let (ib1, ib2
) = tuple_of_list2 ii
in
837 expression ea1 eb1
>>= (fun ea1 eb1
->
838 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
839 expression ea3 eb3
>>= (fun ea3 eb3
->
840 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
841 tokenf ia2 ib2
>>= (fun ia2 ib2
->
843 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
844 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
847 (* todo?: handle some isomorphisms here ? *)
848 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
849 let opbi = tuple_of_list1 ii
in
850 if equal_fixOp (term opa
) opb
852 expression ea eb
>>= (fun ea eb
->
853 tokenf opa
opbi >>= (fun opa
opbi ->
855 ((A.Postfix
(ea
, opa
))) +> wa,
856 ((B.Postfix
(eb
, opb
), typ),[opbi])
861 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
862 let opbi = tuple_of_list1 ii
in
863 if equal_fixOp (term opa
) opb
865 expression ea eb
>>= (fun ea eb
->
866 tokenf opa
opbi >>= (fun opa
opbi ->
868 ((A.Infix
(ea
, opa
))) +> wa,
869 ((B.Infix
(eb
, opb
), typ),[opbi])
873 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
874 let opbi = tuple_of_list1 ii
in
875 if equal_unaryOp (term opa
) opb
877 expression ea eb
>>= (fun ea eb
->
878 tokenf opa
opbi >>= (fun opa
opbi ->
880 ((A.Unary
(ea
, opa
))) +> wa,
881 ((B.Unary
(eb
, opb
), typ),[opbi])
885 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
886 let opbi = tuple_of_list1 ii
in
887 if equal_binaryOp (term opa
) opb
889 expression ea1 eb1
>>= (fun ea1 eb1
->
890 expression ea2 eb2
>>= (fun ea2 eb2
->
891 tokenf opa
opbi >>= (fun opa
opbi ->
893 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
894 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
898 | A.Nested
(ea1
, opa
, ea2
), eb
->
900 (if A.get_test_exp ea1
&& not
(Ast_c.is_test eb
) then fail
901 else expression ea1 eb
) >|+|>
903 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
904 when equal_binaryOp (term opa
) opb
->
905 let opbi = tuple_of_list1 ii
in
907 (expression ea1 eb1
>>= (fun ea1 eb1
->
908 expression ea2 eb2
>>= (fun ea2 eb2
->
909 tokenf opa
opbi >>= (fun opa
opbi ->
911 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
912 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
915 (expression ea2 eb1
>>= (fun ea2 eb1
->
916 expression ea1 eb2
>>= (fun ea1 eb2
->
917 tokenf opa
opbi >>= (fun opa
opbi ->
919 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
920 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
923 (loop eb1
>>= (fun ea1 eb1
->
924 expression ea2 eb2
>>= (fun ea2 eb2
->
925 tokenf opa
opbi >>= (fun opa
opbi ->
927 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
928 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
931 (expression ea2 eb1
>>= (fun ea2 eb1
->
932 loop eb2
>>= (fun ea1 eb2
->
933 tokenf opa
opbi >>= (fun opa
opbi ->
935 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
936 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
938 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
942 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
943 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
944 let (ib1, ib2
) = tuple_of_list2 ii
in
945 expression ea1 eb1
>>= (fun ea1 eb1
->
946 expression ea2 eb2
>>= (fun ea2 eb2
->
947 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
948 tokenf ia2 ib2
>>= (fun ia2 ib2
->
950 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
951 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
954 (* todo?: handle some isomorphisms here ? *)
955 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
956 let (ib1, ib2
) = tuple_of_list2 ii
in
957 ident DontKnow ida
(idb
, ib2
) >>= (fun ida
(idb
, ib2
) ->
958 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
959 expression ea eb
>>= (fun ea eb
->
961 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
962 ((B.RecordAccess
(eb
, idb
), typ), [ib1;ib2
])
967 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
968 let (ib1, ib2
) = tuple_of_list2 ii
in
969 ident DontKnow ida
(idb
, ib2
) >>= (fun ida
(idb
, ib2
) ->
970 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
971 expression ea eb
>>= (fun ea eb
->
973 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
974 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1;ib2
])
978 (* todo?: handle some isomorphisms here ?
979 * todo?: do some iso-by-absence on cast ?
980 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
983 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
984 let (ib1, ib2
) = tuple_of_list2 ii
in
985 fullType typa typb
>>= (fun typa typb
->
986 expression ea eb
>>= (fun ea eb
->
987 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
988 tokenf ia2 ib2
>>= (fun ia2 ib2
->
990 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
991 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
994 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
995 let ib1 = tuple_of_list1 ii
in
996 expression ea eb
>>= (fun ea eb
->
997 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
999 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1000 ((B.SizeOfExpr
(eb
), typ),[ib1])
1003 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1004 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1005 fullType typa typb
>>= (fun typa typb
->
1006 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1007 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1008 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1010 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1011 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1015 (* todo? iso ? allow all the combinations ? *)
1016 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1017 let (ib1, ib2
) = tuple_of_list2 ii
in
1018 expression ea eb
>>= (fun ea eb
->
1019 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1020 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1022 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1023 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1026 | A.NestExpr
(exps
,None
,true), eb
->
1027 (match A.unwrap exps
with
1029 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1031 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1037 "for nestexpr, only handling the case with dots and only one exp")
1039 | A.NestExpr _
, _
->
1040 failwith
"only handling multi and no when code in a nest expr"
1042 (* only in arg lists or in define body *)
1043 | A.TypeExp _
, _
-> fail
1045 (* only in arg lists *)
1046 | A.MetaExprList _
, _
1053 | A.DisjExpr
eas, eb
->
1054 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1056 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1057 failwith
"not handling Opt/Unique/Multi on expr"
1059 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1061 (* have not a counter part in coccinelle, for the moment *)
1062 | _
, ((B.Sequence _
,_
),_
)
1063 | _
, ((B.StatementExpr _
,_
),_
)
1064 | _
, ((B.Constructor _
,_
),_
)
1069 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1070 B.RecordPtAccess
(_
, _
)|
1071 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1072 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1073 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1074 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1075 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1084 (* ------------------------------------------------------------------------- *)
1085 and (ident
: info_ident
-> (A.ident
, string * Ast_c.info
) matcher
) =
1086 fun infoidb ida
((idb
, iib
) as ib
) ->
1087 X.all_bound
(A.get_inherited ida
) >&&>
1088 match A.unwrap ida
with
1090 if (term sa
) =$
= idb
then
1091 tokenf sa iib
>>= (fun sa iib
->
1093 ((A.Id sa
)) +> A.rewrap ida
,
1099 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1100 X.check_constraints
(ident infoidb
) constraints ib
1102 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1103 (* use drop_pos for ids so that the pos is not added a second time in
1104 the call to tokenf *)
1105 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1107 tokenf mida iib
>>= (fun mida iib
->
1109 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1114 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1116 X.check_constraints
(ident infoidb
) constraints ib
1118 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1119 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1121 tokenf mida iib
>>= (fun mida iib
->
1123 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1128 | LocalFunction
| Function
-> is_function()
1130 failwith
"MetaFunc, need more semantic info about id"
1131 (* the following implementation could possibly be useful, if one
1132 follows the convention that a macro is always in capital letters
1133 and that a macro is not a function.
1134 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1137 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1140 X.check_constraints
(ident infoidb
) constraints ib
1142 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1143 X.envf keep inherited
1144 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1146 tokenf mida iib
>>= (fun mida iib
->
1148 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1154 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1157 | A.OptIdent _
| A.UniqueIdent _
->
1158 failwith
"not handling Opt/Unique for ident"
1162 (* ------------------------------------------------------------------------- *)
1163 and (arguments
: sequence
->
1164 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1165 fun seqstyle eas ebs
->
1167 | Unordered
-> failwith
"not handling ooo"
1169 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1170 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1172 (* because '...' can match nothing, need to take care when have
1173 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1174 * f(1,2) for instance.
1175 * So I have added special cases such as (if startxs = []) and code
1176 * in the Ecomma matching rule.
1178 * old: Must do some try, for instance when f(...,X,Y,...) have to
1179 * test the transfo for all the combinaitions and if multiple transfo
1180 * possible ? pb ? => the type is to return a expression option ? use
1181 * some combinators to help ?
1182 * update: with the tag-SP approach, no more a problem.
1185 and arguments_bis
= fun eas ebs
->
1187 | [], [] -> return ([], [])
1188 | [], eb
::ebs
-> fail
1190 X.all_bound
(A.get_inherited ea
) >&&>
1191 (match A.unwrap ea
, ebs
with
1192 | A.Edots
(mcode
, optexpr
), ys
->
1193 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1194 if optexpr
<> None
then failwith
"not handling when in argument";
1196 (* '...' can take more or less the beginnings of the arguments *)
1197 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1198 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1201 (* allow '...', and maybe its associated ',' to match nothing.
1202 * for the associated ',' see below how we handle the EComma
1207 if mcode_contain_plus (mcodekind mcode
)
1209 (* failwith "I have no token that I could accroche myself on" *)
1210 else return (dots2metavar mcode
, [])
1212 (* subtil: we dont want the '...' to match until the
1213 * comma. cf -test pb_params_iso. We would get at
1214 * "already tagged" error.
1215 * this is because both f (... x, ...) and f (..., x, ...)
1216 * would match a f(x,3) with our "optional-comma" strategy.
1218 (match Common.last startxs
with
1221 X.distrf_args
(dots2metavar mcode
) startxs
1224 >>= (fun mcode startxs
->
1225 let mcode = metavar2dots mcode in
1226 arguments_bis
eas endxs
>>= (fun eas endxs
->
1228 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1234 | A.EComma ia1
, Right ii
::ebs
->
1235 let ib1 = tuple_of_list1 ii
in
1236 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1237 arguments_bis
eas ebs
>>= (fun eas ebs
->
1239 (A.EComma ia1
+> A.rewrap ea
)::eas,
1243 | A.EComma ia1
, ebs
->
1244 (* allow ',' to maching nothing. optional comma trick *)
1245 if mcode_contain_plus (mcodekind ia1
)
1247 else arguments_bis
eas ebs
1249 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1250 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1251 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1256 if mcode_contain_plus (mcodekind ida
)
1258 (* failwith "no token that I could accroche myself on" *)
1261 (match Common.last startxs
with
1269 let startxs'
= Ast_c.unsplit_comma
startxs in
1270 let len = List.length
startxs'
in
1273 | Some
(lenname
,lenkeep
,leninherited
) ->
1274 let max_min _
= failwith
"no pos" in
1275 X.envf lenkeep leninherited
1276 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1277 | None
-> function f
-> f
()
1281 Lib_parsing_c.lin_col_by_pos
1282 (Lib_parsing_c.ii_of_args
startxs) in
1283 X.envf keep inherited
1284 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1287 then return (ida
, [])
1288 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1290 >>= (fun ida
startxs ->
1291 arguments_bis
eas endxs
>>= (fun eas endxs
->
1293 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1294 +> A.rewrap ea
::eas,
1302 | _unwrapx
, (Left eb
)::ebs
->
1303 argument ea eb
>>= (fun ea eb
->
1304 arguments_bis
eas ebs
>>= (fun eas ebs
->
1305 return (ea
::eas, Left eb
::ebs
)
1307 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1308 | _unwrapx
, [] -> fail
1312 and argument arga argb
=
1313 X.all_bound
(A.get_inherited arga
) >&&>
1314 match A.unwrap arga
, argb
with
1315 | A.TypeExp tya
, Right
(B.ArgType
(((b
, sopt
, tyb
), ii_b_s
))) ->
1317 if b
|| sopt
<> None
1319 (* failwith "the argument have a storage and ast_cocci does not have"*)
1322 fullType tya tyb
>>= (fun tya tyb
->
1324 (A.TypeExp tya
) +> A.rewrap arga
,
1325 (Right
(B.ArgType
(((b
, sopt
, tyb
), ii_b_s
))))
1328 | A.TypeExp tya
, _
-> fail
1329 | _
, Right
(B.ArgType
(tyb
, sto_iisto
)) -> fail
1331 expression arga argb
>>= (fun arga argb
->
1332 return (arga
, Left argb
)
1334 | _
, Right
(B.ArgAction y
) -> fail
1337 (* ------------------------------------------------------------------------- *)
1338 (* todo? facto code with argument ? *)
1339 and (parameters
: sequence
->
1340 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1342 fun seqstyle eas ebs
->
1344 | Unordered
-> failwith
"not handling ooo"
1346 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1347 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1351 and parameters_bis
eas ebs
=
1353 | [], [] -> return ([], [])
1354 | [], eb
::ebs
-> fail
1356 (* the management of positions is inlined into each case, because
1357 sometimes there is a Param and sometimes a ParamList *)
1358 X.all_bound
(A.get_inherited ea
) >&&>
1359 (match A.unwrap ea
, ebs
with
1360 | A.Pdots
(mcode), ys
->
1362 (* '...' can take more or less the beginnings of the arguments *)
1363 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1364 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1369 if mcode_contain_plus (mcodekind mcode)
1371 (* failwith "I have no token that I could accroche myself on"*)
1372 else return (dots2metavar mcode, [])
1374 (match Common.last
startxs with
1377 X.distrf_params
(dots2metavar mcode) startxs
1379 ) >>= (fun mcode startxs ->
1380 let mcode = metavar2dots mcode in
1381 parameters_bis
eas endxs
>>= (fun eas endxs
->
1383 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1389 | A.PComma ia1
, Right ii
::ebs
->
1390 let ib1 = tuple_of_list1 ii
in
1391 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1392 parameters_bis
eas ebs
>>= (fun eas ebs
->
1394 (A.PComma ia1
+> A.rewrap ea
)::eas,
1399 | A.PComma ia1
, ebs
->
1400 (* try optional comma trick *)
1401 if mcode_contain_plus (mcodekind ia1
)
1403 else parameters_bis
eas ebs
1406 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1407 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1408 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1413 if mcode_contain_plus (mcodekind ida
)
1415 (* failwith "I have no token that I could accroche myself on" *)
1418 (match Common.last
startxs with
1426 let startxs'
= Ast_c.unsplit_comma
startxs in
1427 let len = List.length
startxs'
in
1430 Some
(lenname
,lenkeep
,leninherited
) ->
1431 let max_min _
= failwith
"no pos" in
1432 X.envf lenkeep leninherited
1433 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1434 | None
-> function f
-> f
()
1438 Lib_parsing_c.lin_col_by_pos
1439 (Lib_parsing_c.ii_of_params
startxs) in
1440 X.envf keep inherited
1441 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1444 then return (ida
, [])
1445 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1446 ) >>= (fun ida
startxs ->
1447 parameters_bis
eas endxs
>>= (fun eas endxs
->
1449 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1450 +> A.rewrap ea
::eas,
1458 | A.VoidParam ta
, ys
->
1459 (match eas, ebs
with
1461 let ((hasreg
, idbopt
, tb
), ii_b_s
) = eb
in
1462 if idbopt
= None
&& null ii_b_s
1465 | (qub
, (B.BaseType
B.Void
,_
)) ->
1466 fullType ta tb
>>= (fun ta tb
->
1468 [(A.VoidParam ta
) +> A.rewrap ea
],
1469 [Left
((hasreg
, idbopt
, tb
), ii_b_s
)]
1476 | (A.OptParam _
| A.UniqueParam _
), _
->
1477 failwith
"handling Opt/Unique for Param"
1479 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1482 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1483 (* todo: use quaopt, hasreg ? *)
1485 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1486 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1487 X.distrf_param ida eb
1488 ) >>= (fun ida eb
->
1489 parameters_bis
eas ebs
>>= (fun eas ebs
->
1491 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1496 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1497 (*this should succeed if the C code has a name, and fail otherwise*)
1498 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1499 parameters_bis
eas ebs
>>= (fun eas ebs
->
1501 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1505 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1506 | _unwrapx
, [] -> fail
1513 and parameter
= fun (idaopt
, typa
) ((hasreg
, idbopt
, typb
), ii_b_s
) ->
1514 fullType typa typb
>>= (fun typa typb
->
1515 match idaopt
, Ast_c.split_register_param
(hasreg
, idbopt
, ii_b_s
) with
1516 | Some ida
, Left
(idb
, iihasreg
, iidb
) ->
1517 (* todo: if minus on ida, should also minus the iihasreg ? *)
1518 ident DontKnow ida
(idb
,iidb
) >>= (fun ida
(idb
,iidb
) ->
1521 ((hasreg
, Some idb
, typb
), iihasreg
++[iidb
])
1524 | None
, Right iihasreg
->
1527 ((hasreg
, None
, typb
), iihasreg
)
1531 (* why handle this case ? because of transform_proto ? we may not
1532 * have an ident in the proto.
1533 * If have some plus on ida ? do nothing about ida ?
1535 (* not anymore !!! now that julia is handling the proto.
1536 | _, Right iihasreg ->
1539 ((hasreg, None, typb), iihasreg)
1543 | Some _
, Right _
-> fail
1544 | None
, Left _
-> fail
1550 (* ------------------------------------------------------------------------- *)
1551 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1552 fun (mckstart
, allminus
, decla
) declb
->
1553 X.all_bound
(A.get_inherited decla
) >&&>
1554 match A.unwrap decla
, declb
with
1556 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1557 * de toutes les declarations qui sont au debut d'un fonction et
1558 * commencer le reste du match au premier statement. Alors, ca matche
1559 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1560 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1562 * When the SP want to remove the whole function, the minus is not
1563 * on the MetaDecl but on the MetaRuleElem. So there should
1564 * be no transform of MetaDecl, just matching are allowed.
1567 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1568 (* todo: should not happen in transform mode *)
1569 return ((mckstart
, allminus
, decla
), declb
)
1573 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1574 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1575 (fun decla
(var
,iiptvirgb
,iisto
)->
1576 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1578 (mckstart
, allminus
, decla
),
1579 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1582 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1583 if X.mode
= PatternMode
1585 xs
+> List.fold_left
(fun acc var
->
1587 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1588 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1589 (fun decla
(var
, iiptvirgb
, iisto
) ->
1591 (mckstart
, allminus
, decla
),
1592 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1596 failwith
"More that one variable in decl. Have to split to transform."
1598 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1599 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1601 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1602 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1603 | _
-> raise Impossible
1606 then minusize_list iistob
1607 else return ((), iistob
)
1608 ) >>= (fun () iistob
->
1610 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1611 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1612 tokenf lpa lpb
>>= (fun lpa lpb
->
1613 tokenf rpa rpb
>>= (fun rpa rpb
->
1614 tokenf enda iiendb
>>= (fun enda iiendb
->
1615 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1616 let eas = redots
eas easundots
in
1619 (mckstart
, allminus
,
1620 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1621 (B.MacroDecl
((sb
,ebs
),
1622 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1625 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1629 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1630 X.all_bound
(A.get_inherited decla
) >&&>
1631 match A.unwrap decla
, declb
with
1633 (* kind of typedef iso, we must unfold, it's for the case
1634 * T { }; that we want to match against typedef struct { } xx_t;
1636 | A.TyDecl
(tya0
, ptvirga
),
1637 ({B.v_namei
= Some
((idb
, None
),[iidb
]);
1639 B.v_storage
= (B.StoTypedef
, inl
);
1644 (match A.unwrap tya0
, typb0
with
1645 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1647 (match A.unwrap tya1
, typb1
with
1648 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1649 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1651 let (iisub
, iisbopt
, lbb
, rbb
) =
1654 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1655 (iisub
, [], lbb
, rbb
)
1658 "warning: both a typedef (%s) and struct name introduction (%s)"
1661 pr2
"warning: I will consider only the typedef";
1662 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1663 (iisub
, [iisb
], lbb
, rbb
)
1666 structdef_to_struct_name
1667 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1670 Ast_c.nQ
,((B.TypeName
(idb
, Some
1671 (Lib_parsing_c.al_type
structnameb))), [iidb
])
1674 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1675 tokenf lba lbb
>>= (fun lba lbb
->
1676 tokenf rba rbb
>>= (fun rba rbb
->
1677 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1678 let declsa = redots
declsa undeclsa
in
1680 (match A.unwrap tya2
with
1681 | A.Type
(cv3
, tya3
) ->
1682 (match A.unwrap tya3
with
1683 | A.MetaType
(ida
,keep
, inherited
) ->
1685 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1687 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1688 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1691 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1692 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1693 let typb0 = ((qu
, il
), typb1) in
1695 match fake_typeb with
1696 | _nQ
, ((B.TypeName
(idb
,_typ
)), [iidb
]) ->
1699 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1700 (({B.v_namei
= Some
((idb
, None
),[iidb
]);
1702 B.v_storage
= (B.StoTypedef
, inl
);
1706 iivirg
),iiptvirgb
,iistob
)
1708 | _
-> raise Impossible
1711 | A.StructUnionName
(sua
, sa
) ->
1713 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1715 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1717 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1719 match structnameb with
1720 | _nQ
, (B.StructUnionName
(sub
, s
), [iisub
;iisbopt
]) ->
1722 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1723 [iisub
;iisbopt
;lbb
;rbb
] in
1724 let typb0 = ((qu
, il
), typb1) in
1727 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1728 (({B.v_namei
= Some
((idb
, None
),[iidb
]);
1730 B.v_storage
= (B.StoTypedef
, inl
);
1734 iivirg
),iiptvirgb
,iistob
)
1736 | _
-> raise Impossible
1738 | _
-> raise Impossible
1747 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1748 ({B.v_namei
= Some
((idb
, _
),[iidb
]);
1749 B.v_storage
= (B.StoTypedef
,_
);
1753 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1754 ({B.v_namei
= Some
((idb
, _
),[iidb
]);
1755 B.v_storage
= (B.StoTypedef
,_
);
1761 (* could handle iso here but handled in standard.iso *)
1762 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1763 ({B.v_namei
= Some
((idb
, None
),[iidb
]);
1770 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1771 fullType typa typb
>>= (fun typa typb
->
1772 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1773 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1774 (fun stoa
(stob
, iistob
) ->
1776 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1777 (({B.v_namei
= Some
((idb
,None
),[iidb
]);
1786 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1787 ({B.v_namei
= Some
((idb
,Some inib
),[iidb
;iieqb
]);
1794 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1795 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1796 fullType typa typb
>>= (fun typa typb
->
1797 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1798 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1799 (fun stoa
(stob
, iistob
) ->
1800 initialiser inia inib
>>= (fun inia inib
->
1802 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1803 (({B.v_namei
= Some
((idb
,Some inib
),[iidb
;iieqb
]);
1812 (* do iso-by-absence here ? allow typedecl and var ? *)
1813 | A.TyDecl
(typa
, ptvirga
),
1814 ({B.v_namei
= None
; B.v_type
= typb
;
1820 if stob
= (B.NoSto
, false)
1822 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1823 fullType typa typb
>>= (fun typa typb
->
1825 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1826 (({B.v_namei
= None
;
1831 }, iivirg
), iiptvirgb
, iistob
)
1836 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1837 ({B.v_namei
= Some
((idb
, None
),[iidb
]);
1839 B.v_storage
= (B.StoTypedef
,inline
);
1844 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1845 fullType typa typb
>>= (fun typa typb
->
1848 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
1849 return (stoa
, [iitypedef
])
1851 | _
-> failwith
"wierd, have both typedef and inline or nothing";
1852 ) >>= (fun stoa iistob
->
1853 (match A.unwrap ida
with
1854 | A.MetaType
(_
,_
,_
) ->
1857 Ast_c.nQ
, ((B.TypeName
(idb
, Ast_c.noTypedefDef
())), [iidb
])
1859 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
1860 match fake_typeb with
1861 | _nQ
, ((B.TypeName
(idb
,_typ
)), [iidb
]) ->
1862 return (ida
, (idb
, iidb
))
1863 | _
-> raise Impossible
1867 if (term sa
) =$
= idb
1869 tokenf sa iidb
>>= (fun sa iidb
->
1871 (A.TypeName sa
) +> A.rewrap ida
,
1875 | _
-> raise Impossible
1877 ) >>= (fun ida
(idb
, iidb
) ->
1879 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1880 (({B.v_namei
= Some
((idb
, None
),[iidb
]);
1882 B.v_storage
= (B.StoTypedef
,inline
);
1892 | _
, ({B.v_namei
= None
;}, _
) ->
1893 (* old: failwith "no variable in this declaration, wierd" *)
1898 | A.DisjDecl declas
, declb
->
1899 declas
+> List.fold_left
(fun acc decla
->
1901 (* (declaration (mckstart, allminus, decla) declb) *)
1902 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
1907 (* only in struct type decls *)
1908 | A.Ddots
(dots
,whencode
), _
->
1911 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
1912 failwith
"not handling Opt/Unique Decl"
1914 | _
, ({B.v_namei
=Some _
}, _
)
1920 (* ------------------------------------------------------------------------- *)
1922 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
1923 X.all_bound
(A.get_inherited ia
) >&&>
1924 match (A.unwrap ia
,ib
) with
1926 | (A.InitExpr expa
, ib
) ->
1927 (match A.unwrap expa
, ib
with
1928 | A.Edots
(mcode, None
), ib
->
1929 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
1932 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
1937 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1939 | _
, (B.InitExpr expb
, ii
) ->
1941 expression expa expb
>>= (fun expa expb
->
1943 (A.InitExpr expa
) +> A.rewrap ia
,
1944 (B.InitExpr expb
, ii
)
1949 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
1951 | ib1::ib2
::iicommaopt
->
1952 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1953 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1954 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
1956 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
1957 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
1960 | _
-> raise Impossible
1963 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
1964 failwith
"TODO: not handling whencode in initialisers"
1967 | (A.InitGccDotName
(ia1
, ida
, ia2
, inia
),
1968 (B.InitDesignators
([B.DesignatorField idb
,ii1
], inib
), ii2
))->
1970 let (iidot
, iidb
) = tuple_of_list2 ii1
in
1971 let iieq = tuple_of_list1 ii2
in
1973 tokenf ia1 iidot
>>= (fun ia1 iidot
->
1974 tokenf ia2
iieq >>= (fun ia2
iieq ->
1975 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1976 initialiser inia inib
>>= (fun inia inib
->
1978 (A.InitGccDotName
(ia1
, ida
, ia2
, inia
)) +> A.rewrap ia
,
1980 ([B.DesignatorField idb
, [iidot
;iidb
]], inib
), [iieq])
1984 | (A.InitGccIndex
(ia1
,ea
,ia2
,ia3
,inia
),
1985 (B.InitDesignators
([B.DesignatorIndex eb
, ii1
], inib
), ii2
)) ->
1987 let (ib1, ib2
) = tuple_of_list2 ii1
in
1988 let ib3 = tuple_of_list1 ii2
in
1989 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1990 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1991 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
1992 expression ea eb
>>= (fun ea eb
->
1993 initialiser inia inib
>>= (fun inia inib
->
1995 (A.InitGccIndex
(ia1
,ea
,ia2
,ia3
,inia
)) +> A.rewrap ia
,
1997 ([B.DesignatorIndex eb
, [ib1;ib2
]], inib
), [ib3])
2001 | (A.InitGccRange
(ia1
,e1a
,ia2
,e2a
,ia3
,ia4
,inia
),
2002 (B.InitDesignators
([B.DesignatorRange
(e1b
, e2b
), ii1
], inib
), ii2
)) ->
2004 let (ib1, ib2
, ib3) = tuple_of_list3 ii1
in
2005 let (ib4
) = tuple_of_list1 ii2
in
2006 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2007 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2008 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
2009 tokenf ia4 ib4
>>= (fun ia4 ib4
->
2010 expression e1a e1b
>>= (fun e1a e1b
->
2011 expression e2a e2b
>>= (fun e2a e2b
->
2012 initialiser inia inib
>>= (fun inia inib
->
2014 (A.InitGccRange
(ia1
,e1a
,ia2
,e2a
,ia3
,ia4
,inia
)) +> A.rewrap ia
,
2016 ([B.DesignatorRange
(e1b
, e2b
),[ib1;ib2
;ib3]], inib
), [ib4
])
2022 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2025 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2026 initialiser inia inib
>>= (fun inia inib
->
2027 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2029 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2030 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2037 | A.IComma
(comma
), _
->
2040 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2041 failwith
"not handling Opt/Unique on initialisers"
2043 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2044 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2046 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2054 and initialisers
= fun ias
(ibs
, iicomma
) ->
2055 let ias_unsplit = unsplit_icomma ias
in
2056 let ibs_split = resplit_initialiser ibs iicomma
in
2059 if need_unordered_initialisers ibs
2060 then initialisers_unordered2
2061 else initialisers_ordered2
2063 f ias_unsplit ibs_split >>=
2064 (fun ias_unsplit ibs_split ->
2066 split_icomma ias_unsplit,
2067 unsplit_initialiser ibs_split
2071 (* todo: one day julia will reput a IDots *)
2072 and initialisers_ordered2
= fun ias ibs
->
2074 | [], [] -> return ([], [])
2075 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2076 (match A.unwrap xcomma
with
2077 | A.IComma commax
->
2078 tokenf commax commay
>>= (fun commax commay
->
2079 initialiser x y
>>= (fun x y
->
2080 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2082 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2086 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2092 and initialisers_unordered2
= fun ias ibs
->
2095 | [], ys
-> return ([], ys
)
2096 | (x
,xcomma
)::xs
, ys
->
2098 let permut = Common.uncons_permut_lazy ys
in
2099 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2102 (match A.unwrap xcomma
, e
with
2103 | A.IComma commax
, (y
, commay
) ->
2104 tokenf commax commay
>>= (fun commax commay
->
2105 initialiser x y
>>= (fun x y
->
2107 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2111 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2114 let rest = Lazy.force
rest in
2115 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2118 Common.insert_elem_pos
(e
, pos
) rest
2123 (* ------------------------------------------------------------------------- *)
2124 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2127 | [], [] -> return ([], [])
2128 | [], eb
::ebs
-> fail
2130 X.all_bound
(A.get_inherited ea
) >&&>
2131 (match A.unwrap ea
, ebs
with
2132 | A.Ddots
(mcode, optwhen
), ys
->
2133 if optwhen
<> None
then failwith
"not handling when in argument";
2135 (* '...' can take more or less the beginnings of the arguments *)
2136 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2137 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2142 if mcode_contain_plus (mcodekind mcode)
2144 (* failwith "I have no token that I could accroche myself on" *)
2145 else return (dots2metavar mcode, [])
2148 X.distrf_struct_fields
(dots2metavar mcode) startxs
2149 ) >>= (fun mcode startxs ->
2150 let mcode = metavar2dots mcode in
2151 struct_fields
eas endxs
>>= (fun eas endxs
->
2153 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2158 | _unwrapx
, eb
::ebs
->
2159 struct_field ea eb
>>= (fun ea eb
->
2160 struct_fields
eas ebs
>>= (fun eas ebs
->
2161 return (ea
::eas, eb
::ebs
)
2164 | _unwrapx
, [] -> fail
2167 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2168 let (xfield
, iifield
) = fb
in
2171 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2173 let iiptvirgb = tuple_of_list1 iiptvirg
in
2175 (match onefield_multivars
with
2176 | [] -> raise Impossible
2177 | [onevar
,iivirg
] ->
2178 assert (null iivirg
);
2180 | B.BitField
(sopt
, typb
, expr
), ii
->
2181 pr2_once
"warning: bitfield not handled by ast_cocci";
2183 | B.Simple
(None
, typb
), ii
->
2184 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2186 | B.Simple
(Some idb
, typb
), ii
->
2187 let (iidb
) = tuple_of_list1 ii
in
2189 (* build a declaration from a struct field *)
2190 let allminus = false in
2192 let stob = B.NoSto
, false in
2194 ({B.v_namei
= Some
((idb
, None
),[iidb
]);
2197 B.v_local
= Ast_c.NotLocalDecl
;
2198 B.v_attr
= Ast_c.noattr
;
2202 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2203 (fun fa
(var
,iiptvirgb,iisto) ->
2206 | ({B.v_namei
= Some
((idb
, None
),[iidb
]);
2210 let onevar = B.Simple
(Some idb
, typb
), [iidb
] in
2214 ((B.DeclarationField
2215 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb]))),
2218 | _
-> raise Impossible
2223 pr2_once
"PB: More that one variable in decl. Have to split";
2227 let _iiptvirgb = tuple_of_list1 iifield
in
2230 | B.MacroStructDeclTodo
-> fail
2231 | B.CppDirectiveStruct directive
-> fail
2232 | B.IfdefStruct directive
-> fail
2236 (* ------------------------------------------------------------------------- *)
2237 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2239 X.optional_qualifier_flag
(fun optional_qualifier
->
2240 X.all_bound
(A.get_inherited typa
) >&&>
2241 match A.unwrap typa
, typb
with
2242 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2244 if qu
.B.const
&& qu
.B.volatile
2247 ("warning: the type is both const & volatile but cocci " ^
2248 "does not handle that");
2250 (* Drop out the const/volatile part that has been matched.
2251 * This is because a SP can contain const T v; in which case
2252 * later in match_t_t when we encounter a T, we must not add in
2253 * the environment the whole type.
2258 (* "iso-by-absence" *)
2261 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2263 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2267 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2268 | false, false -> do_stuff ()
2269 | false, true -> fail
2270 | true, false -> do_stuff ()
2273 then pr2_once
"USING optional_qualifier builtin isomorphism";
2279 (* todo: can be __const__ ? can be const & volatile so
2280 * should filter instead ?
2282 (match term x
, il
with
2283 | A.Const
, [i1
] when qu
.B.const
->
2285 tokenf x i1
>>= (fun x i1
->
2286 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2288 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2292 | A.Volatile
, [i1
] when qu
.B.volatile
->
2293 tokenf x i1
>>= (fun x i1
->
2294 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2296 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2304 | A.DisjType typas
, typb
->
2306 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2308 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2309 -> failwith
"not handling Opt/Unique on type"
2314 * Why not (A.typeC, Ast_c.typeC) matcher ?
2315 * because when there is MetaType, we want that T record the whole type,
2316 * including the qualifier, and so this type (and the new_il function in
2317 * preceding function).
2320 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2322 X.all_bound
(A.get_inherited ta
) >&&>
2323 match A.unwrap ta
, tb
with
2326 | A.MetaType
(ida
,keep
, inherited
), typb
->
2328 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2329 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2330 X.distrf_type ida typb
>>= (fun ida typb
->
2332 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2336 | unwrap
, (qub
, typb
) ->
2337 typeC ta typb
>>= (fun ta typb
->
2338 return (ta
, (qub
, typb
))
2342 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2344 match A.unwrap ta
, tb
with
2345 | A.BaseType
(basea
, signaopt
), (B.BaseType baseb
, ii
) ->
2346 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2347 * And even if in baseb we have a Signed Int, that does not mean
2348 * that ii is of length 2, cos Signed is the default, so if in signa
2349 * we have Signed explicitely ? we cant "accrocher" this mcode to
2350 * something :( So for the moment when there is signed in cocci,
2351 * we force that there is a signed in c too (done in pattern.ml).
2353 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2356 (* handle some iso on type ? (cf complex C rule for possible implicit
2358 (match term basea
, baseb
with
2359 | A.VoidType
, B.Void
2360 | A.FloatType
, B.FloatType
(B.CFloat
)
2361 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2362 assert (signaopt
= None
);
2363 let (ibaseb
) = tuple_of_list1 ii
in
2364 tokenf basea ibaseb
>>= (fun basea ibaseb
->
2366 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2367 (B.BaseType baseb
, [ibaseb
])
2370 | A.CharType
, B.IntType
B.CChar
when signaopt
= None
->
2371 let ibaseb = tuple_of_list1 ii
in
2372 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2374 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2375 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2378 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2379 let ibaseb = tuple_of_list1 iibaseb
in
2380 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2381 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2383 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2384 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2387 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2388 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2389 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2392 (* iso-by-presence ? *)
2393 (* when unsigned int in SP, allow have just unsigned in C ? *)
2394 if mcode_contain_plus (mcodekind basea
)
2398 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2400 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2401 (B.BaseType
(baseb
), iisignbopt
++ [])
2407 "warning: long int or short int not handled by ast_cocci";
2411 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2412 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2414 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2415 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2417 | _
-> raise Impossible
2422 | _
, B.IntType
(B.Si
(_
, B.CLongLong
))
2423 | _
, B.FloatType
B.CLongDouble
2426 "warning: long long or long double not handled by ast_cocci";
2429 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2434 | A.ImplicitInt
(signa
), (B.BaseType baseb
, ii
) ->
2435 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2436 (match iibaseb
, baseb
with
2437 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2438 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2440 | None
-> raise Impossible
2443 (A.ImplicitInt
(signa
)) +> A.rewrap ta
,
2444 (B.BaseType baseb
, iisignbopt
)
2452 (* todo? iso with array *)
2453 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2454 let (ibmult
) = tuple_of_list1 ii
in
2455 fullType typa typb
>>= (fun typa typb
->
2456 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2458 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2459 (B.Pointer typb
, [ibmult
])
2462 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2463 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2465 let (lpb
, rpb
) = tuple_of_list2 ii
in
2469 ("Not handling well variable length arguments func. "^
2470 "You have been warned");
2471 tokenf lpa lpb
>>= (fun lpa lpb
->
2472 tokenf rpa rpb
>>= (fun rpa rpb
->
2473 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2474 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2475 (fun paramsaundots paramsb
->
2476 let paramsa = redots
paramsa paramsaundots
in
2478 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2479 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2487 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2488 (B.ParenType t1
, ii
) ->
2489 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2490 let (qu1b
, t1b
) = t1
in
2492 | B.Pointer t2
, ii
->
2493 let (starb
) = tuple_of_list1 ii
in
2494 let (qu2b
, t2b
) = t2
in
2496 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2497 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2502 ("Not handling well variable length arguments func. "^
2503 "You have been warned");
2505 fullType tya tyb
>>= (fun tya tyb
->
2506 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2507 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2508 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2509 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2510 tokenf stara starb
>>= (fun stara starb
->
2511 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2512 (fun paramsaundots paramsb
->
2513 let paramsa = redots
paramsa paramsaundots
in
2517 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2522 (B.Pointer
t2, [starb
]))
2526 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2528 (B.ParenType
t1, [lp1b
;rp1b
])
2541 (* todo: handle the iso on optionnal size specifification ? *)
2542 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2543 let (ib1, ib2
) = tuple_of_list2 ii
in
2544 fullType typa typb
>>= (fun typa typb
->
2545 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2546 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2547 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2549 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2550 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2554 (* todo: could also match a Struct that has provided a name *)
2555 (* This is for the case where the SmPL code contains "struct x", without
2556 a definition. In this case, the name field is always present.
2557 This case is also called from the case for A.StructUnionDef when
2558 a name is present in the C code. *)
2559 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2560 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2561 let (ib1, ib2
) = tuple_of_list2 ii
in
2562 if equal_structUnion (term sua
) sub
2564 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2565 tokenf sua
ib1 >>= (fun sua
ib1 ->
2567 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2568 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2573 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2574 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2576 let (ii_sub_sb
, lbb
, rbb
) =
2578 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2579 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2580 | _
-> failwith
"list of length 3 or 4 expected" in
2583 match (sbopt
,ii_sub_sb
) with
2584 (None
,Common.Left iisub
) ->
2585 (* the following doesn't reconstruct the complete SP code, just
2586 the part that matched *)
2588 match A.unwrap s
with
2590 (match A.unwrap ty
with
2591 A.StructUnionName
(sua
, None
) ->
2592 tokenf sua iisub
>>= (fun sua iisub
->
2595 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2597 return (ty,[iisub
]))
2599 | A.DisjType
(disjs
) ->
2601 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2605 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2607 (* build a StructUnionName from a StructUnion *)
2608 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2610 fullType
ty fake_su >>= (fun ty fake_su ->
2612 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2613 return (ty, [iisub
; iisb
])
2614 | _
-> raise Impossible
)
2618 >>= (fun ty ii_sub_sb
->
2620 tokenf lba lbb
>>= (fun lba lbb
->
2621 tokenf rba rbb
>>= (fun rba rbb
->
2622 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2623 let declsa = redots
declsa undeclsa
in
2626 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2627 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2631 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2632 * uint in the C code. But some CEs consists in renaming some types,
2633 * so we don't want apply isomorphisms every time.
2635 | A.TypeName sa
, (B.TypeName
(sb
,typb
), ii
) ->
2636 let (isb
) = tuple_of_list1 ii
in
2639 tokenf sa isb
>>= (fun sa isb
->
2641 (A.TypeName sa
) +> A.rewrap ta
,
2642 (B.TypeName
(sb
,typb
), [isb
])
2646 | _
, (B.TypeOfExpr e
, ii
) -> fail
2647 | _
, (B.TypeOfType e
, ii
) -> fail
2649 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2650 | _
, (B.EnumName _
, _
) -> fail (* todo cocci ?*)
2651 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
2654 ((B.TypeName
(_
, _
)|B.StructUnionName
(_
, _
)|
2655 B.StructUnion
(_
, _
, _
)|
2656 B.FunctionType _
|B.Array
(_
, _
)|B.Pointer _
|
2662 (* todo: iso on sign, if not mentioned then free. tochange?
2663 * but that require to know if signed int because explicit
2664 * signed int, or because implicit signed int.
2667 and sign signa signb
=
2668 match signa
, signb
with
2669 | None
, None
-> return (None
, [])
2670 | Some signa
, Some
(signb
, ib
) ->
2671 if equal_sign (term signa
) signb
2672 then tokenf signa ib
>>= (fun signa ib
->
2673 return (Some signa
, [ib
])
2679 and minusize_list iixs
=
2680 iixs
+> List.fold_left
(fun acc ii
->
2681 acc
>>= (fun xs ys
->
2682 tokenf minusizer ii
>>= (fun minus ii
->
2683 return (minus
::xs
, ii
::ys
)
2684 ))) (return ([],[]))
2685 >>= (fun _xsminys ys
->
2686 return ((), List.rev ys
)
2689 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
2690 (* "iso-by-absence" for storage, and return type. *)
2691 X.optional_storage_flag
(fun optional_storage
->
2692 match stoa
, stob with
2693 | None
, (stobis
, inline
) ->
2697 minusize_list iistob
>>= (fun () iistob
->
2698 return (None
, (stob, iistob
))
2700 else return (None
, (stob, iistob
))
2703 (match optional_storage
, stobis
with
2704 | false, B.NoSto
-> do_minus ()
2706 | true, B.NoSto
-> do_minus ()
2709 then pr2_once
"USING optional_storage builtin isomorphism";
2713 | Some x
, ((stobis
, inline
)) ->
2714 if equal_storage (term x
) stobis
2718 tokenf x i1
>>= (fun x i1
->
2719 return (Some x
, ((stobis
, inline
), [i1
]))
2721 (* or if have inline ? have to do a split_storage_inline a la
2722 * split_signb_baseb_ii *)
2723 | _
-> raise Impossible
2731 and fullType_optional_allminus
allminus tya retb
=
2736 X.distrf_type
minusizer retb
>>= (fun _x retb
->
2740 else return (None
, retb
)
2742 fullType tya retb
>>= (fun tya retb
->
2743 return (Some tya
, retb
)
2748 (*---------------------------------------------------------------------------*)
2749 and compatible_type a
(b
,_local
) =
2750 let ok = return ((),()) in
2752 let rec loop = function
2753 | Type_cocci.BaseType
(a
, signa
), (qua
, (B.BaseType b
,ii
)) ->
2755 | Type_cocci.VoidType
, B.Void
->
2756 assert (signa
= None
);
2758 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
= None
->
2760 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2761 compatible_sign signa signb
2762 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
2763 compatible_sign signa signb
2764 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
2765 compatible_sign signa signb
2766 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
2767 compatible_sign signa signb
2768 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
2769 pr2_once
"no longlong in cocci";
2771 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
2772 assert (signa
= None
);
2774 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
2775 assert (signa
= None
);
2777 | _
, B.FloatType
B.CLongDouble
->
2778 pr2_once
"no longdouble in cocci";
2780 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
2783 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2788 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
2790 | Type_cocci.FunctionPointer a
, _
->
2792 "TODO: function pointer type doesn't store enough information to determine compatability"
2793 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
2794 (* no size info for cocci *)
2796 | Type_cocci.StructUnionName
(sua
, _
, sa
),
2797 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
2798 if equal_structUnion_type_cocci sua sub
&& sa
= sb
2802 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(sb
,_typb
), ii
)) ->
2807 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
2808 if (fst qub
).B.const
&& (fst qub
).B.volatile
2811 pr2_once
("warning: the type is both const & volatile but cocci " ^
2812 "does not handle that");
2818 | Type_cocci.Const
-> (fst qub
).B.const
2819 | Type_cocci.Volatile
-> (fst qub
).B.volatile
2821 then loop (a
,(Ast_c.nQ
, b
))
2824 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
2826 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2827 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
2831 (* subtil: must be after the MetaType case *)
2832 | a
, (qub
, (B.TypeName
(sb
,Some b
), ii
)) ->
2833 (* kind of typedef iso *)
2840 (* for metavariables of type expression *^* *)
2841 | Type_cocci.Unknown
, _
-> ok
2846 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
2847 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
2854 B.StructUnionName
(_
, _
)|
2856 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
2865 and compatible_sign signa signb
=
2866 let ok = return ((),()) in
2867 match signa
, signb
with
2869 | Some
Type_cocci.Signed
, B.Signed
2870 | Some
Type_cocci.Unsigned
, B.UnSigned
2875 and equal_structUnion_type_cocci a b
=
2877 | Type_cocci.Struct
, B.Struct
-> true
2878 | Type_cocci.Union
, B.Union
-> true
2879 | _
, (B.Struct
| B.Union
) -> false
2883 (*---------------------------------------------------------------------------*)
2884 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
2886 let rec aux_inc (ass
, bss
) passed
=
2890 let passed = List.rev
passed in
2892 (match before_after
, !h_rel_pos
with
2893 | IncludeNothing
, _
-> true
2894 | IncludeMcodeBefore
, Some x
->
2895 List.mem
passed (x
.Ast_c.first_of
)
2897 | IncludeMcodeAfter
, Some x
->
2898 List.mem
passed (x
.Ast_c.last_of
)
2900 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
2904 | (A.IncPath x
)::xs
, y
::ys
-> x
= y
&& aux_inc (xs
, ys
) (x
::passed)
2905 | _
-> failwith
"IncDots not in last place or other pb"
2910 | A.Local ass
, B.Local bss
->
2911 aux_inc (ass
, bss
) []
2912 | A.NonLocal ass
, B.NonLocal bss
->
2913 aux_inc (ass
, bss
) []
2918 (*---------------------------------------------------------------------------*)
2920 and (define_params
: sequence
->
2921 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
2922 fun seqstyle eas ebs
->
2924 | Unordered
-> failwith
"not handling ooo"
2926 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
2927 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
2930 (* todo? facto code with argument and parameters ? *)
2931 and define_paramsbis
= fun eas ebs
->
2933 | [], [] -> return ([], [])
2934 | [], eb
::ebs
-> fail
2936 X.all_bound
(A.get_inherited ea
) >&&>
2937 (match A.unwrap ea
, ebs
with
2938 | A.DPdots
(mcode), ys
->
2940 (* '...' can take more or less the beginnings of the arguments *)
2941 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2942 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2947 if mcode_contain_plus (mcodekind mcode)
2949 (* failwith "I have no token that I could accroche myself on" *)
2950 else return (dots2metavar mcode, [])
2952 (match Common.last
startxs with
2955 X.distrf_define_params
(dots2metavar mcode) startxs
2957 ) >>= (fun mcode startxs ->
2958 let mcode = metavar2dots mcode in
2959 define_paramsbis
eas endxs
>>= (fun eas endxs
->
2961 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
2967 | A.DPComma ia1
, Right ii
::ebs
->
2968 let ib1 = tuple_of_list1 ii
in
2969 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2970 define_paramsbis
eas ebs
>>= (fun eas ebs
->
2972 (A.DPComma ia1
+> A.rewrap ea
)::eas,
2977 | A.DPComma ia1
, ebs
->
2978 if mcode_contain_plus (mcodekind ia1
)
2981 (define_paramsbis
eas ebs
) (* try optional comma trick *)
2983 | (A.OptDParam _
| A.UniqueDParam _
), _
->
2984 failwith
"handling Opt/Unique for define parameters"
2986 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
2988 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
2989 let ib1 = tuple_of_list1 ii
in
2990 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
2991 define_paramsbis
eas ebs
>>= (fun eas ebs
->
2993 (A.DParam ida
)+> A.rewrap ea
:: eas,
2994 (Left
(idb
, [ib1]))::ebs
2997 | _unwrapx
, (Right y
)::ys
-> raise Impossible
2998 | _unwrapx
, [] -> fail
3003 (*****************************************************************************)
3005 (*****************************************************************************)
3007 (* no global solution for positions here, because for a statement metavariable
3008 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3010 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3013 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3015 X.all_bound
(A.get_inherited re
) >&&>
3018 match A.unwrap re
, F.unwrap node
with
3020 (* note: the order of the clauses is important. *)
3022 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3024 (* the metaRuleElem contains just '-' information. We dont need to add
3025 * stuff in the environment. If we need stuff in environment, because
3026 * there is a + S somewhere, then this will be done via MetaStmt, not
3028 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3031 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3032 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3033 (match unwrap_node
with
3035 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
3037 if X.mode
= PatternMode
3040 if mcode_contain_plus (mcodekind mcode)
3041 then failwith
"try add stuff on fake node"
3042 (* minusize or contextize a fake node is ok *)
3045 | F.EndStatement None
->
3046 if X.mode
= PatternMode
then return default
3048 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3049 if mcode_contain_plus (mcodekind mcode)
3051 let fake_info = Ast_c.fakeInfo() in
3052 distrf distrf_node (mcodekind mcode)
3053 (F.EndStatement (Some fake_info))
3054 else return unwrap_node
3058 | F.EndStatement
(Some i1
) ->
3059 tokenf mcode i1
>>= (fun mcode i1
->
3061 A.MetaRuleElem
(mcode,keep
, inherited
),
3062 F.EndStatement
(Some i1
)
3066 if X.mode
= PatternMode
then return default
3067 else failwith
"a MetaRuleElem can't transform a headfunc"
3069 if X.mode
= PatternMode
then return default
3071 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3073 A.MetaRuleElem
(mcode,keep
, inherited
),
3079 (* rene cant have found that a state containing a fake/exit/... should be
3081 * TODO: and F.Fake ?
3083 | _
, F.EndStatement _
| _
, F.CaseNode _
3084 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
| _
, F.FallThroughNode
3088 (* really ? diff between pattern.ml and transformation.ml *)
3089 | _
, F.Fake
-> fail2()
3092 (* cas general: a Meta can match everything. It matches only
3093 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3094 * So can't have been called in transform.
3096 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3098 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3099 (* todo: should not happen in transform mode *)
3101 (match Control_flow_c.extract_fullstatement node
with
3104 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3105 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3107 (* no need tag ida, we can't be called in transform-mode *)
3109 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3117 | A.MetaStmtList _
, _
->
3118 failwith
"not handling MetaStmtList"
3120 | A.TopExp ea
, F.DefineExpr eb
->
3121 expression ea eb
>>= (fun ea eb
->
3127 | A.TopExp ea
, F.DefineType eb
->
3128 (match A.unwrap ea
with
3130 fullType ft eb
>>= (fun ft eb
->
3132 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3139 (* It is important to put this case before the one that fails because
3140 * of the lack of the counter part of a C construct in SmPL (for instance
3141 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3142 * yet certain constructs, those constructs may contain expression
3143 * that we still want and can transform.
3146 | A.Exp exp
, nodeb
->
3148 (* kind of iso, initialisation vs affectation *)
3150 match A.unwrap exp
, nodeb
with
3151 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3152 initialisation_to_affectation decl
+> F.rewrap node
3157 (* Now keep fullstatement inside the control flow node,
3158 * so that can then get in a MetaStmtVar the fullstatement to later
3159 * pp back when the S is in a +. But that means that
3160 * Exp will match an Ifnode even if there is no such exp
3161 * inside the condition of the Ifnode (because the exp may
3162 * be deeper, in the then branch). So have to not visit
3163 * all inside a node anymore.
3165 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3166 * fois le fullstatement et le partialstatement et appeler le
3167 * visiteur que sur le partialstatement.
3170 match Ast_cocci.get_pos re
with
3171 | None
-> expression
3175 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3176 let keep = Type_cocci.Unitary
in
3177 let inherited = false in
3178 let max_min _
= failwith
"no pos" in
3179 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3185 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3193 X.cocciTy fullType
ty node >>= (fun ty node ->
3200 | A.TopInit init
, nodeb
->
3201 X.cocciInit initialiser init
node >>= (fun init
node ->
3209 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3210 F.FunHeader
({B.f_name
= idb
;
3211 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3218 (* fninfoa records the order in which the SP specified the various
3219 information, but this isn't taken into account in the matching.
3220 Could this be a problem for transformation? *)
3223 List.filter
(function A.FStorage
(s
) -> true | _
-> false) fninfoa
3224 with [A.FStorage
(s
)] -> Some s
| _
-> None
in
3226 match List.filter
(function A.FType
(s
) -> true | _
-> false) fninfoa
3227 with [A.FType
(t
)] -> Some t
| _
-> None
in
3229 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3230 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3232 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3233 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3236 | iidb
::ioparenb
::icparenb
::iifakestart
::iistob
->
3238 (* maybe important to put ident as the first tokens to transform.
3239 * It's related to transform_proto. So don't change order
3242 ident LocalFunction ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3243 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3244 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3245 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3246 parameters
(seqstyle paramsa)
3247 (A.undots
paramsa) paramsb
>>=
3248 (fun paramsaundots paramsb
->
3249 let paramsa = redots
paramsa paramsaundots
in
3250 storage_optional_allminus
allminus
3251 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3256 ("Not handling well variable length arguments func. "^
3257 "You have been warned");
3259 then minusize_list iidotsb
3260 else return ((),iidotsb
)
3261 ) >>= (fun () iidotsb
->
3263 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3266 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3267 (match tya with Some t
-> [A.FType t
] | None
-> [])
3272 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3274 F.FunHeader
({B.f_name
= idb
;
3275 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3280 iidb
::ioparenb
::icparenb
::iifakestart
::iistob
)
3283 | _
-> raise Impossible
3291 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3292 declaration
(mckstart
,allminus,decla
) declb
>>=
3293 (fun (mckstart
,allminus,decla
) declb
->
3295 A.Decl
(mckstart
,allminus,decla
),
3300 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3301 tokenf mcode i1
>>= (fun mcode i1
->
3304 F.SeqStart
(st
, level
, i1
)
3307 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3308 tokenf mcode i1
>>= (fun mcode i1
->
3311 F.SeqEnd
(level
, i1
)
3314 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3315 let ib1 = tuple_of_list1 ii
in
3316 expression ea eb
>>= (fun ea eb
->
3317 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3319 A.ExprStatement
(ea
, ia1
),
3320 F.ExprStatement
(st
, (Some eb
, [ib1]))
3325 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3326 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3327 expression ea eb
>>= (fun ea eb
->
3328 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3329 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3330 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3332 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3333 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3336 | A.Else ia
, F.Else ib
->
3337 tokenf ia ib
>>= (fun ia ib
->
3338 return (A.Else ia
, F.Else ib
)
3341 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3342 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3343 expression ea eb
>>= (fun ea eb
->
3344 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3345 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3346 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3348 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3349 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3]))
3352 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3353 tokenf ia ib
>>= (fun ia ib
->
3358 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3359 let (ib1, ib2
, ib3, ib4
) = tuple_of_list4 ii
in
3360 expression ea eb
>>= (fun ea eb
->
3361 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3362 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3363 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3364 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3366 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3367 F.DoWhileTail
(eb
, [ib1;ib2
;ib3;ib4
])
3369 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s
,ebs
),ii
))
3371 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3373 ident DontKnow ia1
(s
, ib1) >>= (fun ia1
(s
, ib1) ->
3374 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3375 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3376 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3377 let eas = redots
eas easundots
in
3379 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3380 F.MacroIterHeader
(st
, ((s
,ebs
), [ib1;ib2
;ib3]))
3385 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3386 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3388 assert (null ib4vide
);
3389 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3390 let ib3 = tuple_of_list1 ib3s
in
3391 let ib4 = tuple_of_list1 ib4s
in
3393 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3394 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3395 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3396 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3397 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3398 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3399 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3400 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3402 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3403 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3409 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3410 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3411 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3412 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3413 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3414 expression ea eb
>>= (fun ea eb
->
3416 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3417 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3420 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3421 let (ib1, ib2
) = tuple_of_list2 ii
in
3422 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3423 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3426 F.Break
(st
, ((),[ib1;ib2
]))
3429 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3430 let (ib1, ib2
) = tuple_of_list2 ii
in
3431 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3432 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3434 A.Continue
(ia1
, ia2
),
3435 F.Continue
(st
, ((),[ib1;ib2
]))
3438 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3439 let (ib1, ib2
) = tuple_of_list2 ii
in
3440 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3441 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3443 A.Return
(ia1
, ia2
),
3444 F.Return
(st
, ((),[ib1;ib2
]))
3447 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3448 let (ib1, ib2
) = tuple_of_list2 ii
in
3449 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3450 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3451 expression ea eb
>>= (fun ea eb
->
3453 A.ReturnExpr
(ia1
, ea
, ia2
),
3454 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3459 | A.Include
(incla
,filea
),
3460 F.Include
{B.i_include
= (fileb
, ii
);
3461 B.i_rel_pos
= h_rel_pos
;
3462 B.i_is_in_ifdef
= inifdef
;
3465 assert (copt
= None
);
3467 let include_requirment =
3468 match mcodekind incla
, mcodekind filea
with
3469 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3471 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3477 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3478 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3480 tokenf incla inclb
>>= (fun incla inclb
->
3481 tokenf filea iifileb
>>= (fun filea iifileb
->
3483 A.Include
(incla
, filea
),
3484 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3485 B.i_rel_pos
= h_rel_pos
;
3486 B.i_is_in_ifdef
= inifdef
;
3494 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3495 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3496 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3497 tokenf definea defineb
>>= (fun definea defineb
->
3498 (match A.unwrap params
, defkind
with
3499 | A.NoParams
, B.DefineVar
->
3501 A.NoParams
+> A.rewrap params
,
3504 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3505 let (lpb
, rpb
) = tuple_of_list2 ii
in
3506 tokenf lpa lpb
>>= (fun lpa lpb
->
3507 tokenf rpa rpb
>>= (fun rpa rpb
->
3509 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3510 (fun easundots ebs
->
3511 let eas = redots
eas easundots
in
3513 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3514 B.DefineFunc
(ebs
,[lpb
;rpb
])
3518 ) >>= (fun params defkind
->
3520 A.DefineHeader
(definea
, ida
, params
),
3521 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3526 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3527 let (ib1, ib2
) = tuple_of_list2 ii
in
3528 tokenf def
ib1 >>= (fun def
ib1 ->
3529 tokenf colon ib2
>>= (fun colon ib2
->
3531 A.Default
(def
,colon
),
3532 F.Default
(st
, ((),[ib1;ib2
]))
3537 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3538 let (ib1, ib2
) = tuple_of_list2 ii
in
3539 tokenf case
ib1 >>= (fun case
ib1 ->
3540 expression ea eb
>>= (fun ea eb
->
3541 tokenf colon ib2
>>= (fun colon ib2
->
3543 A.Case
(case
,ea
,colon
),
3544 F.Case
(st
, (eb
,[ib1;ib2
]))
3547 (* only occurs in the predicates generated by asttomember *)
3548 | A.DisjRuleElem
eas, _
->
3550 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3551 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3553 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3555 | A.Label
(id,dd
), F.Label
(st
,(s
,ii
)) ->
3556 let (ib1,ib2
) = tuple_of_list2 ii
in
3557 let (string_of_id
,rebuild
) =
3558 match A.unwrap
id with
3559 A.Id
(s
) -> (s
,function s
-> A.rewrap id (A.Id
(s
)))
3560 | _
-> failwith
"labels with metavariables not supported" in
3561 if (term string_of_id
) =$
= s
3563 tokenf string_of_id
ib1 >>= (fun string_of_id
ib1 ->
3564 tokenf dd ib2
>>= (fun dd ib2
->
3566 A.Label
(rebuild string_of_id
,dd
),
3567 F.Label
(st
,(s
,[ib1;ib2
]))
3571 | A.Goto
(goto
,id,sem
), F.Goto
(st
,(s
,ii
)) ->
3572 let (ib1,ib2
,ib3) = tuple_of_list3 ii
in
3573 tokenf goto
ib1 >>= (fun goto
ib1 ->
3574 ident DontKnow
id (s
, ib2
) >>= (fun id (s
, ib2
) ->
3575 tokenf sem
ib3 >>= (fun sem
ib3 ->
3577 A.Goto
(goto
,id,sem
),
3578 F.Goto
(st
,(s
,[ib1;ib2
;ib3]))
3581 (* have not a counter part in coccinelle, for the moment *)
3582 (* todo?: print a warning at least ? *)
3588 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3592 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3595 (F.Label
(_
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3596 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3597 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3598 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3599 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3600 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3601 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3602 F.Decl _
|F.FunHeader _
)