2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
28 module F = Control_flow_c
30 module Flag = Flag_matcher
32 (*****************************************************************************)
34 (*****************************************************************************)
36 (*****************************************************************************)
38 (*****************************************************************************)
40 type sequence = Ordered | Unordered
43 match A.unwrap eas with
45 | A.CIRCLES _ -> Unordered
46 | A.STARS _ -> failwith "not handling stars"
48 let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
50 match A.unwrap eas with
51 | A.DOTS _ -> A.DOTS easundots
52 | A.CIRCLES _ -> A.CIRCLES easundots
53 | A.STARS _ -> A.STARS easundots
57 let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
59 ibs +> List.exists (fun (ib, icomma) ->
60 match B.unwrap ib with
70 (* For the #include <linux/...> in the .cocci, need to find where is
71 * the '+' attached to this element, to later find the first concrete
72 * #include <linux/xxx.h> or last one in the serie of #includes in the
75 type include_requirement =
82 (* todo? put in semantic_c.ml *)
85 | LocalFunction (* entails Function *)
89 let term mc = A.unwrap_mcode mc
90 let mcodekind mc = A.get_mcodekind mc
93 let mcode_contain_plus = function
94 | A.CONTEXT (_,A.NOTHING) -> false
96 | A.MINUS (_,[]) -> false
97 | A.MINUS (_,x::xs) -> true
98 | A.PLUS -> raise Impossible
100 let mcode_simple_minus = function
101 | A.MINUS (_,[]) -> true
105 (* In transformation.ml sometime I build some mcodekind myself and
106 * julia has put None for the pos. But there is no possible raise
107 * NoMatch in those cases because it is for the minusall trick or for
108 * the distribute, so either have to build those pos, in fact a range,
109 * because for the distribute have to erase a fullType with one
110 * mcodekind, or add an argument to tag_with_mck such as "safe" that
111 * don't do the check_pos. Hence this DontCarePos constructor. *)
115 {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
116 (A.MINUS(A.DontCarePos, [])),
119 let generalize_mcode ia =
120 let (s1, i, mck, pos) = ia in
123 | A.PLUS -> raise Impossible
124 | A.CONTEXT (A.NoPos,x) ->
125 A.CONTEXT (A.DontCarePos,x)
126 | A.MINUS (A.NoPos,x) ->
127 A.MINUS (A.DontCarePos,x)
129 | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
130 | A.MINUS ((A.FixPos _|A.DontCarePos), _)
134 (s1, i, new_mck, pos)
138 (*---------------------------------------------------------------------------*)
140 (* 0x0 is equivalent to 0, value format isomorphism *)
141 let equal_c_int s1 s2 =
143 int_of_string s1 = int_of_string s2
144 with Failure("int_of_string") ->
149 (*---------------------------------------------------------------------------*)
150 (* Normally A should reuse some types of Ast_c, so those
151 * functions should not exist.
153 * update: but now Ast_c depends on A, so can't make too
154 * A depends on Ast_c, so have to stay with those equal_xxx
158 let equal_unaryOp a b =
160 | A.GetRef , B.GetRef -> true
161 | A.DeRef , B.DeRef -> true
162 | A.UnPlus , B.UnPlus -> true
163 | A.UnMinus , B.UnMinus -> true
164 | A.Tilde , B.Tilde -> true
165 | A.Not , B.Not -> true
166 | _, B.GetRefLabel -> false (* todo cocci? *)
167 | _, (B.Not|B.Tilde|B.UnMinus|B.UnPlus|B.DeRef|B.GetRef) -> false
171 let equal_arithOp a b =
173 | A.Plus , B.Plus -> true
174 | A.Minus , B.Minus -> true
175 | A.Mul , B.Mul -> true
176 | A.Div , B.Div -> true
177 | A.Mod , B.Mod -> true
178 | A.DecLeft , B.DecLeft -> true
179 | A.DecRight , B.DecRight -> true
180 | A.And , B.And -> true
181 | A.Or , B.Or -> true
182 | A.Xor , B.Xor -> true
183 | _, (B.Xor|B.Or|B.And|B.DecRight|B.DecLeft|B.Mod|B.Div|B.Mul|B.Minus|B.Plus)
186 let equal_logicalOp a b =
188 | A.Inf , B.Inf -> true
189 | A.Sup , B.Sup -> true
190 | A.InfEq , B.InfEq -> true
191 | A.SupEq , B.SupEq -> true
192 | A.Eq , B.Eq -> true
193 | A.NotEq , B.NotEq -> true
194 | A.AndLog , B.AndLog -> true
195 | A.OrLog , B.OrLog -> true
196 | _, (B.OrLog|B.AndLog|B.NotEq|B.Eq|B.SupEq|B.InfEq|B.Sup|B.Inf)
199 let equal_assignOp a b =
201 | A.SimpleAssign, B.SimpleAssign -> true
202 | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
203 | _, (B.OpAssign _|B.SimpleAssign) -> false
205 let equal_fixOp a b =
207 | A.Dec, B.Dec -> true
208 | A.Inc, B.Inc -> true
209 | _, (B.Inc|B.Dec) -> false
211 let equal_binaryOp a b =
213 | A.Arith a, B.Arith b -> equal_arithOp a b
214 | A.Logical a, B.Logical b -> equal_logicalOp a b
215 | _, (B.Logical _ | B.Arith _) -> false
217 let equal_structUnion a b =
219 | A.Struct, B.Struct -> true
220 | A.Union, B.Union -> true
221 | _, (B.Struct|B.Union) -> false
225 | A.Signed, B.Signed -> true
226 | A.Unsigned, B.UnSigned -> true
227 | _, (B.UnSigned|B.Signed) -> false
229 let equal_storage a b =
231 | A.Static , B.Sto B.Static
232 | A.Auto , B.Sto B.Auto
233 | A.Register , B.Sto B.Register
234 | A.Extern , B.Sto B.Extern
236 | _, (B.NoSto | B.StoTypedef) -> false
237 | _, (B.Sto (B.Register|B.Static|B.Auto|B.Extern)) -> false
240 (*---------------------------------------------------------------------------*)
242 let equal_metavarval valu valu' =
243 match valu, valu' with
244 | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
245 | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
246 | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
247 (* do something more ? *)
250 (* al_expr before comparing !!! and accept when they match.
251 * Note that here we have Astc._expression, so it is a match
252 * modulo isomorphism (there is no metavariable involved here,
253 * just isomorphisms). => TODO call isomorphism_c_c instead of
254 * =*=. Maybe would be easier to transform ast_c in ast_cocci
255 * and call the iso engine of julia. *)
256 | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
257 Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
258 | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
259 Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
261 | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
262 Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
263 | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
264 Lib_parsing_c.al_init a =*= Lib_parsing_c.al_init b
265 | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
266 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
269 | Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
271 | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
272 Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
273 | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
274 Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
276 | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
277 Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
279 | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
281 (function (fla,cea,posa1,posa2) ->
283 (function (flb,ceb,posb1,posb2) ->
284 fla = flb && cea = ceb &&
285 Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
289 | (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
290 |B.MetaTypeVal _ |B.MetaInitVal _
291 |B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
292 |B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
297 (*---------------------------------------------------------------------------*)
298 (* could put in ast_c.ml, next to the split/unsplit_comma *)
299 let split_signb_baseb_ii (baseb, ii) =
300 let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
301 match baseb, iis with
303 | B.Void, ["void",i1] -> None, [i1]
305 | B.FloatType (B.CFloat),["float",i1] -> None, [i1]
306 | B.FloatType (B.CDouble),["double",i1] -> None, [i1]
307 | B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
309 | B.IntType (B.CChar), ["char",i1] -> None, [i1]
312 | B.IntType (B.Si (sign, base)), xs ->
313 (match sign, base, xs with
314 | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
315 Some (B.Signed, i1), [i2]
316 | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
317 Some (B.UnSigned, i1), [i2]
319 | B.Signed, B.CShort, ["short",i1] ->
321 | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
322 Some (B.Signed, i1), [i2]
323 | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
324 Some (B.UnSigned, i1), [i2]
325 | B.Signed, B.CShort, ["short",i1;"int",i2] ->
328 | B.Signed, B.CInt, ["int",i1] ->
330 | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
331 Some (B.Signed, i1), [i2]
332 | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
333 Some (B.UnSigned, i1), [i2]
335 | B.Signed, B.CInt, ["signed",i1;] ->
336 Some (B.Signed, i1), []
337 | B.UnSigned, B.CInt, ["unsigned",i1;] ->
338 Some (B.UnSigned, i1), []
340 | B.Signed, B.CLong, ["long",i1] ->
342 | B.Signed, B.CLong, ["long",i1;"int",i2] ->
344 | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
345 Some (B.Signed, i1), [i2]
346 | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
347 Some (B.UnSigned, i1), [i2]
349 | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
350 | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
351 Some (B.Signed, i1), [i2;i3]
352 | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
353 Some (B.UnSigned, i1), [i2;i3]
356 | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
357 Some (B.UnSigned, i1), [i2;i3]
361 | _ -> failwith "strange type1, maybe because of weird order"
363 | _ -> failwith "strange type2, maybe because of weird order"
365 (*---------------------------------------------------------------------------*)
367 let rec unsplit_icomma xs =
371 (match A.unwrap y with
373 (x, y)::unsplit_icomma xs
374 | _ -> failwith "wrong ast_cocci in initializer"
377 failwith ("wrong ast_cocci in initializer, should have pair " ^
382 let resplit_initialiser ibs iicomma =
383 match iicomma, ibs with
386 failwith "should have a iicomma, do you generate fakeInfo in parser?"
388 failwith "shouldn't have a iicomma"
389 | [iicomma], x::xs ->
390 let elems = List.map fst (x::xs) in
391 let commas = List.map snd (x::xs) +> List.flatten in
392 let commas = commas @ [iicomma] in
394 | _ -> raise Impossible
398 let rec split_icomma xs =
401 | (x,y)::xs -> x::y::split_icomma xs
403 let rec unsplit_initialiser ibs_unsplit =
404 match ibs_unsplit with
405 | [] -> [], [] (* empty iicomma *)
407 let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
408 (x, [])::xs, lastcomma
410 and unsplit_initialiser_bis comma_before = function
411 | [] -> [], [comma_before]
413 let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
414 (x, [comma_before])::xs, lastcomma
419 (*---------------------------------------------------------------------------*)
420 (* coupling: same in type_annotater_c.ml *)
421 let structdef_to_struct_name ty =
423 | qu, (B.StructUnion (su, sopt, fields), iis) ->
425 | Some s , [i1;i2;i3;i4] ->
426 qu, (B.StructUnionName (su, s), [i1;i2])
430 | x -> raise Impossible
432 | _ -> raise Impossible
434 (*---------------------------------------------------------------------------*)
435 let initialisation_to_affectation decl =
437 | B.MacroDecl _ -> F.Decl decl
438 | B.DeclList (xs, iis) ->
440 (* todo?: should not do that if the variable is an array cos
441 * will have x[] = , mais de toute facon ca sera pas un InitExp
444 | [] -> raise Impossible
446 let ({B.v_namei = var;
447 B.v_type = returnType;
448 B.v_storage = storage;
453 | Some ((s, ini), iis::iini) ->
455 | Some (B.InitExpr e, ii_empty2) ->
458 Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
459 | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
462 ref (Some ((Lib_parsing_c.al_type returnType),local),
464 let id = (B.Ident s, typ),[iis] in
466 ((B.Assignment (id, B.SimpleAssign, e),
467 Ast_c.noType()), iini)
473 pr2_once "TODO: initialisation_to_affectation for multi vars";
474 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
475 * the Sequence expression operator of C and make an
476 * ExprStatement from that.
485 (*****************************************************************************)
486 (* Functor parameter combinators *)
487 (*****************************************************************************)
489 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
491 * version0: was not tagging the SP, so just tag the C
493 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
494 * val return : 'b -> tin -> 'b tout
495 * val fail : tin -> 'b tout
497 * version1: now also tag the SP so return a ('a * 'b)
500 type mode = PatternMode | TransformMode
508 type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
513 (tin -> ('a * 'b) tout) ->
514 ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
515 (tin -> ('c * 'd) tout)
517 val return : ('a * 'b) -> tin -> ('a *'b) tout
518 val fail : tin -> ('a * 'b) tout
530 val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
532 val tokenf : ('a A.mcode, B.info) matcher
533 val tokenf_mck : (A.mcodekind, B.info) matcher
536 (A.meta_name A.mcode, B.expression) matcher
538 (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
540 (A.meta_name A.mcode, Ast_c.fullType) matcher
542 (A.meta_name A.mcode,
543 (Ast_c.parameterType, Ast_c.il) either list) matcher
545 (A.meta_name A.mcode, Ast_c.parameterType) matcher
547 (A.meta_name A.mcode, Ast_c.initialiser) matcher
549 (A.meta_name A.mcode, Control_flow_c.node) matcher
551 val distrf_define_params :
552 (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
555 val distrf_struct_fields :
556 (A.meta_name A.mcode, B.field list) matcher
559 (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
562 (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
565 (A.expression, B.expression) matcher ->
566 (A.expression, B.expression) matcher
569 (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
572 (A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
575 A.keep_binding -> A.inherited ->
576 A.meta_name A.mcode * Ast_c.metavar_binding_kind *
577 (unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
578 (unit -> tin -> 'x tout) -> (tin -> 'x tout)
580 val check_constraints :
581 ('a, 'b) matcher -> 'a list -> 'b ->
582 (unit -> tin -> 'x tout) -> (tin -> 'x tout)
584 val all_bound : A.meta_name list -> (tin -> bool)
586 val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
587 val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
588 val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
593 (*****************************************************************************)
594 (* Functor code, "Cocci vs C" *)
595 (*****************************************************************************)
598 functor (X : PARAM) ->
601 type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
604 let return = X.return
607 let (>||>) = X.(>||>)
608 let (>|+|>) = X.(>|+|>)
609 let (>&&>) = X.(>&&>)
611 let tokenf = X.tokenf
613 (* should be raise Impossible when called from transformation.ml *)
616 | PatternMode -> fail
617 | TransformMode -> raise Impossible
620 let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
622 | (Some t1, Some t2) ->
623 f t1 t2 >>= (fun t1 t2 ->
624 return (Some t1, Some t2)
626 | (None, None) -> return (None, None)
629 (* Dots are sometimes used as metavariables, since like metavariables they
630 can match other things. But they no longer have the same type. Perhaps these
631 functions could be avoided by introducing an appropriate level of polymorphism,
632 but I don't know how to declare polymorphism across functors *)
633 let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
634 let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
636 (*---------------------------------------------------------------------------*)
648 (*---------------------------------------------------------------------------*)
649 let rec (expression: (A.expression, Ast_c.expression) matcher) =
651 X.all_bound (A.get_inherited ea) >&&>
652 let wa x = A.rewrap ea x in
653 match A.unwrap ea, eb with
655 (* general case: a MetaExpr can match everything *)
656 | A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
657 (((expr, opttypb), ii) as expb) ->
659 (* old: before have a MetaConst. Now we factorize and use 'form' to
660 * differentiate between different cases *)
661 let rec matches_id = function
663 | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
666 match (form,expr) with
669 let rec matches = function
670 B.Constant(c) -> true
671 | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
672 pr2_once ("warning: I consider " ^ idb ^ " as a constant");
674 | B.Cast(ty,e) -> matches (B.unwrap_expr e)
675 | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
676 | B.SizeOfExpr(exp) -> true
677 | B.SizeOfType(ty) -> true
683 (Some (_,Ast_c.LocalVar _),_) -> true
685 | (A.ID,e) -> matches_id e in
689 (let (opttypb,_testb) = !opttypb in
690 match opttypa, opttypb with
691 | None, _ -> return ((),())
693 pr2_once ("Missing type information. Certainly a pb in " ^
694 "annotate_typer.ml");
697 | Some tas, Some tb ->
698 tas +> List.fold_left (fun acc ta ->
699 acc >|+|> compatible_type ta tb) fail
702 X.check_constraints expression constraints eb
705 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
706 X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
708 X.distrf_e ida expb >>= (fun ida expb ->
710 A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
718 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
719 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
721 * but bug! because if have not tagged SP, then transform without doing
722 * any checks. Hopefully now have tagged SP technique.
727 * | A.Edots _, _ -> raise Impossible.
729 * In fact now can also have the Edots inside normal expression, not
730 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
732 | A.Edots (mcode, None), expb ->
733 X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
735 A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
740 | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
743 | A.Ident ida, ((B.Ident idb, typ),ii) ->
744 let ib1 = tuple_of_list1 ii in
745 ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
747 ((A.Ident ida)) +> wa,
748 ((B.Ident idb, typ),[ib1])
754 | A.MetaErr _, _ -> failwith "not handling MetaErr"
756 (* todo?: handle some isomorphisms in int/float ? can have different
757 * format : 1l can match a 1.
759 * todo: normally string can contain some metavar too, so should
760 * recurse on the string
762 | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
763 (* for everything except the String case where can have multi elems *)
765 let ib1 = tuple_of_list1 ii in
766 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
768 ((A.Constant ia1)) +> wa,
769 ((B.Constant (ib), typ),[ib1])
772 (match term ia1, ib with
773 | A.Int x, B.Int y ->
774 X.value_format_flag (fun use_value_equivalence ->
775 if use_value_equivalence
785 | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
787 | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
790 | A.String sa, B.String (sb,_kind) when sa =$= sb ->
793 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
795 ((A.Constant ia1)) +> wa,
796 ((B.Constant (ib), typ),[ib1])
798 | _ -> fail (* multi string, not handled *)
801 | _, B.MultiString -> (* todo cocci? *) fail
802 | _, (B.String _ | B.Float _ | B.Char _ | B.Int _) -> fail
806 | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
807 (* todo: do special case to allow IdMetaFunc, cos doing the
808 * recursive call will be too late, match_ident will not have the
809 * info whether it was a function. todo: but how detect when do
810 * x.field = f; how know that f is a Func ? By having computed
811 * some information before the matching!
813 * Allow match with FunCall containing types. Now ast_cocci allow
814 * type in parameter, and morover ast_cocci allow f(...) and those
815 * ... could match type.
817 let (ib1, ib2) = tuple_of_list2 ii in
818 expression ea eb >>= (fun ea eb ->
819 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
820 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
821 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
822 let eas = redots eas easundots in
824 ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
825 ((B.FunCall (eb, ebs),typ), [ib1;ib2])
831 | A.Assignment (ea1, opa, ea2, simple),
832 ((B.Assignment (eb1, opb, eb2), typ),ii) ->
833 let (opbi) = tuple_of_list1 ii in
834 if equal_assignOp (term opa) opb
836 expression ea1 eb1 >>= (fun ea1 eb1 ->
837 expression ea2 eb2 >>= (fun ea2 eb2 ->
838 tokenf opa opbi >>= (fun opa opbi ->
840 ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
841 ((B.Assignment (eb1, opb, eb2), typ), [opbi])
845 | A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
846 let (ib1, ib2) = tuple_of_list2 ii in
847 expression ea1 eb1 >>= (fun ea1 eb1 ->
848 option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
849 expression ea3 eb3 >>= (fun ea3 eb3 ->
850 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
851 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
853 ((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
854 ((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
857 (* todo?: handle some isomorphisms here ? *)
858 | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
859 let opbi = tuple_of_list1 ii in
860 if equal_fixOp (term opa) opb
862 expression ea eb >>= (fun ea eb ->
863 tokenf opa opbi >>= (fun opa opbi ->
865 ((A.Postfix (ea, opa))) +> wa,
866 ((B.Postfix (eb, opb), typ),[opbi])
871 | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
872 let opbi = tuple_of_list1 ii in
873 if equal_fixOp (term opa) opb
875 expression ea eb >>= (fun ea eb ->
876 tokenf opa opbi >>= (fun opa opbi ->
878 ((A.Infix (ea, opa))) +> wa,
879 ((B.Infix (eb, opb), typ),[opbi])
883 | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
884 let opbi = tuple_of_list1 ii in
885 if equal_unaryOp (term opa) opb
887 expression ea eb >>= (fun ea eb ->
888 tokenf opa opbi >>= (fun opa opbi ->
890 ((A.Unary (ea, opa))) +> wa,
891 ((B.Unary (eb, opb), typ),[opbi])
895 | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
896 let opbi = tuple_of_list1 ii in
897 if equal_binaryOp (term opa) opb
899 expression ea1 eb1 >>= (fun ea1 eb1 ->
900 expression ea2 eb2 >>= (fun ea2 eb2 ->
901 tokenf opa opbi >>= (fun opa opbi ->
903 ((A.Binary (ea1, opa, ea2))) +> wa,
904 ((B.Binary (eb1, opb, eb2), typ),[opbi]
908 | A.Nested (ea1, opa, ea2), eb ->
910 (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
911 else expression ea1 eb) >|+|>
913 ((B.Binary (eb1, opb, eb2), typ),ii)
914 when equal_binaryOp (term opa) opb ->
915 let opbi = tuple_of_list1 ii in
917 (expression ea1 eb1 >>= (fun ea1 eb1 ->
918 expression ea2 eb2 >>= (fun ea2 eb2 ->
919 tokenf opa opbi >>= (fun opa opbi ->
921 ((A.Nested (ea1, opa, ea2))) +> wa,
922 ((B.Binary (eb1, opb, eb2), typ),[opbi]
925 (expression ea2 eb1 >>= (fun ea2 eb1 ->
926 expression ea1 eb2 >>= (fun ea1 eb2 ->
927 tokenf opa opbi >>= (fun opa opbi ->
929 ((A.Nested (ea1, opa, ea2))) +> wa,
930 ((B.Binary (eb1, opb, eb2), typ),[opbi]
933 (loop eb1 >>= (fun ea1 eb1 ->
934 expression ea2 eb2 >>= (fun ea2 eb2 ->
935 tokenf opa opbi >>= (fun opa opbi ->
937 ((A.Nested (ea1, opa, ea2))) +> wa,
938 ((B.Binary (eb1, opb, eb2), typ),[opbi]
941 (expression ea2 eb1 >>= (fun ea2 eb1 ->
942 loop eb2 >>= (fun ea1 eb2 ->
943 tokenf opa opbi >>= (fun opa opbi ->
945 ((A.Nested (ea1, opa, ea2))) +> wa,
946 ((B.Binary (eb1, opb, eb2), typ),[opbi]
948 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
952 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
953 | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
954 let (ib1, ib2) = tuple_of_list2 ii in
955 expression ea1 eb1 >>= (fun ea1 eb1 ->
956 expression ea2 eb2 >>= (fun ea2 eb2 ->
957 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
958 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
960 ((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
961 ((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
964 (* todo?: handle some isomorphisms here ? *)
965 | A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
966 let (ib1, ib2) = tuple_of_list2 ii in
967 ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
968 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
969 expression ea eb >>= (fun ea eb ->
971 ((A.RecordAccess (ea, ia1, ida))) +> wa,
972 ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
977 | A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
978 let (ib1, ib2) = tuple_of_list2 ii in
979 ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
980 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
981 expression ea eb >>= (fun ea eb ->
983 ((A.RecordPtAccess (ea, ia1, ida))) +> wa,
984 ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
988 (* todo?: handle some isomorphisms here ?
989 * todo?: do some iso-by-absence on cast ?
990 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
993 | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
994 let (ib1, ib2) = tuple_of_list2 ii in
995 fullType typa typb >>= (fun typa typb ->
996 expression ea eb >>= (fun ea eb ->
997 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
998 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1000 ((A.Cast (ia1, typa, ia2, ea))) +> wa,
1001 ((B.Cast (typb, eb),typ),[ib1;ib2])
1004 | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
1005 let ib1 = tuple_of_list1 ii in
1006 expression ea eb >>= (fun ea eb ->
1007 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1009 ((A.SizeOfExpr (ia1, ea))) +> wa,
1010 ((B.SizeOfExpr (eb), typ),[ib1])
1013 | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
1014 let (ib1,ib2,ib3) = tuple_of_list3 ii in
1015 fullType typa typb >>= (fun typa typb ->
1016 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1017 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1018 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
1020 ((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
1021 ((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
1025 (* todo? iso ? allow all the combinations ? *)
1026 | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
1027 let (ib1, ib2) = tuple_of_list2 ii in
1028 expression ea eb >>= (fun ea eb ->
1029 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1030 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1032 ((A.Paren (ia1, ea, ia2))) +> wa,
1033 ((B.ParenExpr (eb), typ), [ib1;ib2])
1036 | A.NestExpr(exps,None,true), eb ->
1037 (match A.unwrap exps with
1039 X.cocciExpExp expression exp eb >>= (fun exp eb ->
1041 (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
1047 "for nestexpr, only handling the case with dots and only one exp")
1049 | A.NestExpr _, _ ->
1050 failwith "only handling multi and no when code in a nest expr"
1052 (* only in arg lists or in define body *)
1053 | A.TypeExp _, _ -> fail
1055 (* only in arg lists *)
1056 | A.MetaExprList _, _
1063 | A.DisjExpr eas, eb ->
1064 eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
1066 | A.UniqueExp _,_ | A.OptExp _,_ ->
1067 failwith "not handling Opt/Unique/Multi on expr"
1069 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1071 (* have not a counter part in coccinelle, for the moment *)
1072 | _, ((B.Sequence _,_),_)
1073 | _, ((B.StatementExpr _,_),_)
1074 | _, ((B.Constructor _,_),_)
1079 (((B.Cast (_, _)|B.ParenExpr _|B.SizeOfType _|B.SizeOfExpr _|
1080 B.RecordPtAccess (_, _)|
1081 B.RecordAccess (_, _)|B.ArrayAccess (_, _)|
1082 B.Binary (_, _, _)|B.Unary (_, _)|
1083 B.Infix (_, _)|B.Postfix (_, _)|
1084 B.Assignment (_, _, _)|B.CondExpr (_, _, _)|
1085 B.FunCall (_, _)|B.Constant _|B.Ident _),
1094 (* ------------------------------------------------------------------------- *)
1095 and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
1096 fun infoidb ida ((idb, iib) as ib) ->
1097 X.all_bound (A.get_inherited ida) >&&>
1098 match A.unwrap ida with
1100 if (term sa) =$= idb then
1101 tokenf sa iib >>= (fun sa iib ->
1103 ((A.Id sa)) +> A.rewrap ida,
1109 | A.MetaId(mida,constraints,keep,inherited) ->
1110 X.check_constraints (ident infoidb) constraints ib
1112 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1113 (* use drop_pos for ids so that the pos is not added a second time in
1114 the call to tokenf *)
1115 X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
1117 tokenf mida iib >>= (fun mida iib ->
1119 ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
1124 | A.MetaFunc(mida,constraints,keep,inherited) ->
1126 X.check_constraints (ident infoidb) constraints ib
1128 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1129 X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
1131 tokenf mida iib >>= (fun mida iib ->
1133 ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
1138 | LocalFunction | Function -> is_function()
1140 failwith "MetaFunc, need more semantic info about id"
1141 (* the following implementation could possibly be useful, if one
1142 follows the convention that a macro is always in capital letters
1143 and that a macro is not a function.
1144 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1147 | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
1150 X.check_constraints (ident infoidb) constraints ib
1152 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1153 X.envf keep inherited
1154 (A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
1156 tokenf mida iib >>= (fun mida iib ->
1158 ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
1164 | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
1167 | A.OptIdent _ | A.UniqueIdent _ ->
1168 failwith "not handling Opt/Unique for ident"
1172 (* ------------------------------------------------------------------------- *)
1173 and (arguments: sequence ->
1174 (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
1175 fun seqstyle eas ebs ->
1177 | Unordered -> failwith "not handling ooo"
1179 arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
1180 return (eas, (Ast_c.unsplit_comma ebs_splitted))
1182 (* because '...' can match nothing, need to take care when have
1183 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1184 * f(1,2) for instance.
1185 * So I have added special cases such as (if startxs = []) and code
1186 * in the Ecomma matching rule.
1188 * old: Must do some try, for instance when f(...,X,Y,...) have to
1189 * test the transfo for all the combinaitions and if multiple transfo
1190 * possible ? pb ? => the type is to return a expression option ? use
1191 * some combinators to help ?
1192 * update: with the tag-SP approach, no more a problem.
1195 and arguments_bis = fun eas ebs ->
1197 | [], [] -> return ([], [])
1198 | [], eb::ebs -> fail
1200 X.all_bound (A.get_inherited ea) >&&>
1201 (match A.unwrap ea, ebs with
1202 | A.Edots (mcode, optexpr), ys ->
1203 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1204 if optexpr <> None then failwith "not handling when in argument";
1206 (* '...' can take more or less the beginnings of the arguments *)
1207 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1208 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1211 (* allow '...', and maybe its associated ',' to match nothing.
1212 * for the associated ',' see below how we handle the EComma
1217 if mcode_contain_plus (mcodekind mcode)
1219 (* failwith "I have no token that I could accroche myself on" *)
1220 else return (dots2metavar mcode, [])
1222 (* subtil: we dont want the '...' to match until the
1223 * comma. cf -test pb_params_iso. We would get at
1224 * "already tagged" error.
1225 * this is because both f (... x, ...) and f (..., x, ...)
1226 * would match a f(x,3) with our "optional-comma" strategy.
1228 (match Common.last startxs with
1231 X.distrf_args (dots2metavar mcode) startxs
1234 >>= (fun mcode startxs ->
1235 let mcode = metavar2dots mcode in
1236 arguments_bis eas endxs >>= (fun eas endxs ->
1238 (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
1244 | A.EComma ia1, Right ii::ebs ->
1245 let ib1 = tuple_of_list1 ii in
1246 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1247 arguments_bis eas ebs >>= (fun eas ebs ->
1249 (A.EComma ia1 +> A.rewrap ea)::eas,
1253 | A.EComma ia1, ebs ->
1254 (* allow ',' to maching nothing. optional comma trick *)
1255 if mcode_contain_plus (mcodekind ia1)
1257 else arguments_bis eas ebs
1259 | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
1260 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1261 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1266 if mcode_contain_plus (mcodekind ida)
1268 (* failwith "no token that I could accroche myself on" *)
1271 (match Common.last startxs with
1279 let startxs' = Ast_c.unsplit_comma startxs in
1280 let len = List.length startxs' in
1283 | Some (lenname,lenkeep,leninherited) ->
1284 let max_min _ = failwith "no pos" in
1285 X.envf lenkeep leninherited
1286 (lenname, Ast_c.MetaListlenVal (len), max_min)
1287 | None -> function f -> f()
1291 Lib_parsing_c.lin_col_by_pos
1292 (Lib_parsing_c.ii_of_args startxs) in
1293 X.envf keep inherited
1294 (ida, Ast_c.MetaExprListVal startxs', max_min)
1297 then return (ida, [])
1298 else X.distrf_args ida (Ast_c.split_comma startxs')
1300 >>= (fun ida startxs ->
1301 arguments_bis eas endxs >>= (fun eas endxs ->
1303 (A.MetaExprList(ida,leninfo,keep,inherited))
1304 +> A.rewrap ea::eas,
1312 | _unwrapx, (Left eb)::ebs ->
1313 argument ea eb >>= (fun ea eb ->
1314 arguments_bis eas ebs >>= (fun eas ebs ->
1315 return (ea::eas, Left eb::ebs)
1317 | _unwrapx, (Right y)::ys -> raise Impossible
1318 | _unwrapx, [] -> fail
1322 and argument arga argb =
1323 X.all_bound (A.get_inherited arga) >&&>
1324 match A.unwrap arga, argb with
1325 | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
1327 if b || sopt <> None
1329 (* failwith "the argument have a storage and ast_cocci does not have"*)
1332 fullType tya tyb >>= (fun tya tyb ->
1334 (A.TypeExp tya) +> A.rewrap arga,
1335 (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
1338 | A.TypeExp tya, _ -> fail
1339 | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
1341 expression arga argb >>= (fun arga argb ->
1342 return (arga, Left argb)
1344 | _, Right (B.ArgAction y) -> fail
1347 (* ------------------------------------------------------------------------- *)
1348 (* todo? facto code with argument ? *)
1349 and (parameters: sequence ->
1350 (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
1352 fun seqstyle eas ebs ->
1354 | Unordered -> failwith "not handling ooo"
1356 parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
1357 return (eas, (Ast_c.unsplit_comma ebs_splitted))
1361 and parameters_bis eas ebs =
1363 | [], [] -> return ([], [])
1364 | [], eb::ebs -> fail
1366 (* the management of positions is inlined into each case, because
1367 sometimes there is a Param and sometimes a ParamList *)
1368 X.all_bound (A.get_inherited ea) >&&>
1369 (match A.unwrap ea, ebs with
1370 | A.Pdots (mcode), ys ->
1372 (* '...' can take more or less the beginnings of the arguments *)
1373 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1374 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1379 if mcode_contain_plus (mcodekind mcode)
1381 (* failwith "I have no token that I could accroche myself on"*)
1382 else return (dots2metavar mcode, [])
1384 (match Common.last startxs with
1387 X.distrf_params (dots2metavar mcode) startxs
1389 ) >>= (fun mcode startxs ->
1390 let mcode = metavar2dots mcode in
1391 parameters_bis eas endxs >>= (fun eas endxs ->
1393 (A.Pdots (mcode) +> A.rewrap ea) ::eas,
1399 | A.PComma ia1, Right ii::ebs ->
1400 let ib1 = tuple_of_list1 ii in
1401 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1402 parameters_bis eas ebs >>= (fun eas ebs ->
1404 (A.PComma ia1 +> A.rewrap ea)::eas,
1409 | A.PComma ia1, ebs ->
1410 (* try optional comma trick *)
1411 if mcode_contain_plus (mcodekind ia1)
1413 else parameters_bis eas ebs
1416 | A.MetaParamList(ida,leninfo,keep,inherited),ys->
1417 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1418 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1423 if mcode_contain_plus (mcodekind ida)
1425 (* failwith "I have no token that I could accroche myself on" *)
1428 (match Common.last startxs with
1436 let startxs' = Ast_c.unsplit_comma startxs in
1437 let len = List.length startxs' in
1440 Some (lenname,lenkeep,leninherited) ->
1441 let max_min _ = failwith "no pos" in
1442 X.envf lenkeep leninherited
1443 (lenname, Ast_c.MetaListlenVal (len), max_min)
1444 | None -> function f -> f()
1448 Lib_parsing_c.lin_col_by_pos
1449 (Lib_parsing_c.ii_of_params startxs) in
1450 X.envf keep inherited
1451 (ida, Ast_c.MetaParamListVal startxs', max_min)
1454 then return (ida, [])
1455 else X.distrf_params ida (Ast_c.split_comma startxs')
1456 ) >>= (fun ida startxs ->
1457 parameters_bis eas endxs >>= (fun eas endxs ->
1459 (A.MetaParamList(ida,leninfo,keep,inherited))
1460 +> A.rewrap ea::eas,
1468 | A.VoidParam ta, ys ->
1469 (match eas, ebs with
1471 let ((hasreg, idbopt, tb), ii_b_s) = eb in
1472 if idbopt = None && null ii_b_s
1475 | (qub, (B.BaseType B.Void,_)) ->
1476 fullType ta tb >>= (fun ta tb ->
1478 [(A.VoidParam ta) +> A.rewrap ea],
1479 [Left ((hasreg, idbopt, tb), ii_b_s)]
1486 | (A.OptParam _ | A.UniqueParam _), _ ->
1487 failwith "handling Opt/Unique for Param"
1489 | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
1492 | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
1493 (* todo: use quaopt, hasreg ? *)
1495 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
1496 X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
1497 X.distrf_param ida eb
1498 ) >>= (fun ida eb ->
1499 parameters_bis eas ebs >>= (fun eas ebs ->
1501 (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
1506 | A.Param (typa, idaopt), (Left eb)::ebs ->
1507 (*this should succeed if the C code has a name, and fail otherwise*)
1508 parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
1509 parameters_bis eas ebs >>= (fun eas ebs ->
1511 (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
1515 | _unwrapx, (Right y)::ys -> raise Impossible
1516 | _unwrapx, [] -> fail
1523 and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
1524 fullType typa typb >>= (fun typa typb ->
1525 match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
1526 | Some ida, Left (idb, iihasreg, iidb) ->
1527 (* todo: if minus on ida, should also minus the iihasreg ? *)
1528 ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
1531 ((hasreg, Some idb, typb), iihasreg++[iidb])
1534 | None, Right iihasreg ->
1537 ((hasreg, None, typb), iihasreg)
1541 (* why handle this case ? because of transform_proto ? we may not
1542 * have an ident in the proto.
1543 * If have some plus on ida ? do nothing about ida ?
1545 (* not anymore !!! now that julia is handling the proto.
1546 | _, Right iihasreg ->
1549 ((hasreg, None, typb), iihasreg)
1553 | Some _, Right _ -> fail
1554 | None, Left _ -> fail
1560 (* ------------------------------------------------------------------------- *)
1561 and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
1562 fun (mckstart, allminus, decla) declb ->
1563 X.all_bound (A.get_inherited decla) >&&>
1564 match A.unwrap decla, declb with
1566 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1567 * de toutes les declarations qui sont au debut d'un fonction et
1568 * commencer le reste du match au premier statement. Alors, ca matche
1569 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1570 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1572 * When the SP want to remove the whole function, the minus is not
1573 * on the MetaDecl but on the MetaRuleElem. So there should
1574 * be no transform of MetaDecl, just matching are allowed.
1577 | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
1578 (* todo: should not happen in transform mode *)
1579 return ((mckstart, allminus, decla), declb)
1583 | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
1584 onedecl allminus decla (var,iiptvirgb,iisto) >>=
1585 (fun decla (var,iiptvirgb,iisto)->
1586 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1588 (mckstart, allminus, decla),
1589 (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
1592 | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
1593 if X.mode = PatternMode
1595 xs +> List.fold_left (fun acc var ->
1597 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1598 onedecl allminus decla (var, iiptvirgb, iisto) >>=
1599 (fun decla (var, iiptvirgb, iisto) ->
1601 (mckstart, allminus, decla),
1602 (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
1606 failwith "More that one variable in decl. Have to split to transform."
1608 | A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
1609 let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
1611 | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
1612 (iisb,lpb,rpb,iiendb, iifakestart,iisto)
1613 | _ -> raise Impossible
1616 then minusize_list iistob
1617 else return ((), iistob)
1618 ) >>= (fun () iistob ->
1620 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1621 ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
1622 tokenf lpa lpb >>= (fun lpa lpb ->
1623 tokenf rpa rpb >>= (fun rpa rpb ->
1624 tokenf enda iiendb >>= (fun enda iiendb ->
1625 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
1626 let eas = redots eas easundots in
1629 (mckstart, allminus,
1630 (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
1631 (B.MacroDecl ((sb,ebs),
1632 [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
1635 | _, (B.MacroDecl _ |B.DeclList _) -> fail
1639 and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
1640 X.all_bound (A.get_inherited decla) >&&>
1641 match A.unwrap decla, declb with
1643 (* kind of typedef iso, we must unfold, it's for the case
1644 * T { }; that we want to match against typedef struct { } xx_t;
1646 | A.TyDecl (tya0, ptvirga),
1647 ({B.v_namei = Some ((idb, None),[iidb]);
1649 B.v_storage = (B.StoTypedef, inl);
1654 (match A.unwrap tya0, typb0 with
1655 | A.Type(cv1,tya1), ((qu,il),typb1) ->
1657 (match A.unwrap tya1, typb1 with
1658 | A.StructUnionDef(tya2, lba, declsa, rba),
1659 (B.StructUnion (sub, sbopt, declsb), ii) ->
1661 let (iisub, iisbopt, lbb, rbb) =
1664 let (iisub, lbb, rbb) = tuple_of_list3 ii in
1665 (iisub, [], lbb, rbb)
1668 "warning: both a typedef (%s) and struct name introduction (%s)"
1671 pr2 "warning: I will consider only the typedef";
1672 let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
1673 (iisub, [iisb], lbb, rbb)
1676 structdef_to_struct_name
1677 (Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
1680 Ast_c.nQ,((B.TypeName (idb, Some
1681 (Lib_parsing_c.al_type structnameb))), [iidb])
1684 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1685 tokenf lba lbb >>= (fun lba lbb ->
1686 tokenf rba rbb >>= (fun rba rbb ->
1687 struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
1688 let declsa = redots declsa undeclsa in
1690 (match A.unwrap tya2 with
1691 | A.Type(cv3, tya3) ->
1692 (match A.unwrap tya3 with
1693 | A.MetaType(ida,keep, inherited) ->
1695 fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
1697 A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
1698 let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
1701 let typb1 = B.StructUnion (sub,sbopt, declsb),
1702 [iisub] @ iisbopt @ [lbb;rbb] in
1703 let typb0 = ((qu, il), typb1) in
1705 match fake_typeb with
1706 | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
1709 (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
1710 (({B.v_namei = Some ((idb, None),[iidb]);
1712 B.v_storage = (B.StoTypedef, inl);
1716 iivirg),iiptvirgb,iistob)
1718 | _ -> raise Impossible
1721 | A.StructUnionName(sua, sa) ->
1723 fullType tya2 structnameb >>= (fun tya2 structnameb ->
1725 let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
1727 let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
1729 match structnameb with
1730 | _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
1732 let typb1 = B.StructUnion (sub,sbopt, declsb),
1733 [iisub;iisbopt;lbb;rbb] in
1734 let typb0 = ((qu, il), typb1) in
1737 (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
1738 (({B.v_namei = Some ((idb, None),[iidb]);
1740 B.v_storage = (B.StoTypedef, inl);
1744 iivirg),iiptvirgb,iistob)
1746 | _ -> raise Impossible
1748 | _ -> raise Impossible
1757 | A.UnInit (stoa, typa, ida, ptvirga),
1758 ({B.v_namei = Some ((idb, _),[iidb]);
1759 B.v_storage = (B.StoTypedef,_);
1763 | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
1764 ({B.v_namei = Some ((idb, _),[iidb]);
1765 B.v_storage = (B.StoTypedef,_);
1771 (* could handle iso here but handled in standard.iso *)
1772 | A.UnInit (stoa, typa, ida, ptvirga),
1773 ({B.v_namei = Some ((idb, None),[iidb]);
1780 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1781 fullType typa typb >>= (fun typa typb ->
1782 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1783 storage_optional_allminus allminus stoa (stob, iistob) >>=
1784 (fun stoa (stob, iistob) ->
1786 (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
1787 (({B.v_namei = Some ((idb,None),[iidb]);
1796 | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
1797 ({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
1804 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1805 tokenf eqa iieqb >>= (fun eqa iieqb ->
1806 fullType typa typb >>= (fun typa typb ->
1807 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1808 storage_optional_allminus allminus stoa (stob, iistob) >>=
1809 (fun stoa (stob, iistob) ->
1810 initialiser inia inib >>= (fun inia inib ->
1812 (A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
1813 (({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
1822 (* do iso-by-absence here ? allow typedecl and var ? *)
1823 | A.TyDecl (typa, ptvirga),
1824 ({B.v_namei = None; B.v_type = typb;
1830 if stob = (B.NoSto, false)
1832 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1833 fullType typa typb >>= (fun typa typb ->
1835 (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
1836 (({B.v_namei = None;
1841 }, iivirg), iiptvirgb, iistob)
1846 | A.Typedef (stoa, typa, ida, ptvirga),
1847 ({B.v_namei = Some ((idb, None),[iidb]);
1849 B.v_storage = (B.StoTypedef,inline);
1854 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1855 fullType typa typb >>= (fun typa typb ->
1858 tokenf stoa iitypedef >>= (fun stoa iitypedef ->
1859 return (stoa, [iitypedef])
1861 | _ -> failwith "wierd, have both typedef and inline or nothing";
1862 ) >>= (fun stoa iistob ->
1863 (match A.unwrap ida with
1864 | A.MetaType(_,_,_) ->
1867 Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
1869 fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
1870 match fake_typeb with
1871 | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
1872 return (ida, (idb, iidb))
1873 | _ -> raise Impossible
1877 if (term sa) =$= idb
1879 tokenf sa iidb >>= (fun sa iidb ->
1881 (A.TypeName sa) +> A.rewrap ida,
1885 | _ -> raise Impossible
1887 ) >>= (fun ida (idb, iidb) ->
1889 (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
1890 (({B.v_namei = Some ((idb, None),[iidb]);
1892 B.v_storage = (B.StoTypedef,inline);
1902 | _, ({B.v_namei = None;}, _) ->
1903 (* old: failwith "no variable in this declaration, wierd" *)
1908 | A.DisjDecl declas, declb ->
1909 declas +> List.fold_left (fun acc decla ->
1911 (* (declaration (mckstart, allminus, decla) declb) *)
1912 (onedecl allminus decla (declb,iiptvirgb, iistob))
1917 (* only in struct type decls *)
1918 | A.Ddots(dots,whencode), _ ->
1921 | A.OptDecl _, _ | A.UniqueDecl _, _ ->
1922 failwith "not handling Opt/Unique Decl"
1924 | _, ({B.v_namei=Some _}, _)
1930 (* ------------------------------------------------------------------------- *)
1932 and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
1933 X.all_bound (A.get_inherited ia) >&&>
1934 match (A.unwrap ia,ib) with
1936 | (A.MetaInit(ida,keep,inherited), ib) ->
1938 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_ini ib) in
1939 X.envf keep inherited (ida, Ast_c.MetaInitVal ib, max_min)
1941 X.distrf_ini ida ib >>= (fun ida ib ->
1943 A.MetaInit (ida,keep,inherited) +> A.rewrap ia,
1948 | (A.InitExpr expa, ib) ->
1949 (match A.unwrap expa, ib with
1950 | A.Edots (mcode, None), ib ->
1951 X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
1954 (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
1959 | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
1961 | _, (B.InitExpr expb, ii) ->
1963 expression expa expb >>= (fun expa expb ->
1965 (A.InitExpr expa) +> A.rewrap ia,
1966 (B.InitExpr expb, ii)
1971 | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
1973 | ib1::ib2::iicommaopt ->
1974 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1975 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1976 initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
1978 (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
1979 (B.InitList ibs, ib1::ib2::iicommaopt)
1982 | _ -> raise Impossible
1985 | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
1986 failwith "TODO: not handling whencode in initialisers"
1989 | (A.InitGccExt (designatorsa, ia2, inia),
1990 (B.InitDesignators (designatorsb, inib), ii2))->
1992 let iieq = tuple_of_list1 ii2 in
1994 tokenf ia2 iieq >>= (fun ia2 iieq ->
1995 designators designatorsa designatorsb >>=
1996 (fun designatorsa designatorsb ->
1997 initialiser inia inib >>= (fun inia inib ->
1999 (A.InitGccExt (designatorsa, ia2, inia)) +> A.rewrap ia,
2000 (B.InitDesignators (designatorsb, inib), [iieq])
2006 | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
2009 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
2010 initialiser inia inib >>= (fun inia inib ->
2011 tokenf ia1 iicolon >>= (fun ia1 iicolon ->
2013 (A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
2014 (B.InitFieldOld (idb, inib), [iidb;iicolon])
2021 | A.IComma(comma), _ ->
2024 | A.UniqueIni _,_ | A.OptIni _,_ ->
2025 failwith "not handling Opt/Unique on initialisers"
2027 | _, (B.InitIndexOld (_, _), _) -> fail
2028 | _, (B.InitFieldOld (_, _), _) -> fail
2030 | _, ((B.InitDesignators (_, _)|B.InitList _|B.InitExpr _), _)
2033 and designators dla dlb =
2034 match (dla,dlb) with
2035 ([],[]) -> return ([], [])
2036 | ([],_) | (_,[]) -> fail
2037 | (da::dla,db::dlb) ->
2038 designator da db >>= (fun da db ->
2039 designators dla dlb >>= (fun dla dlb ->
2040 return (da::dla, db::dlb)))
2042 and designator da db =
2044 (A.DesignatorField (ia1, ida), (B.DesignatorField idb,ii1)) ->
2046 let (iidot, iidb) = tuple_of_list2 ii1 in
2047 tokenf ia1 iidot >>= (fun ia1 iidot ->
2048 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
2050 A.DesignatorField (ia1, ida),
2051 (B.DesignatorField idb, [iidot;iidb])
2054 | (A.DesignatorIndex (ia1,ea,ia2), (B.DesignatorIndex eb, ii1)) ->
2056 let (ib1, ib2) = tuple_of_list2 ii1 in
2057 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
2058 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
2059 expression ea eb >>= (fun ea eb ->
2061 A.DesignatorIndex (ia1,ea,ia2),
2062 (B.DesignatorIndex eb, [ib1;ib2])
2065 | (A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
2066 (B.DesignatorRange (e1b, e2b), ii1)) ->
2068 let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
2069 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
2070 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
2071 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
2072 expression e1a e1b >>= (fun e1a e1b ->
2073 expression e2a e2b >>= (fun e2a e2b ->
2075 A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
2076 (B.DesignatorRange (e1b, e2b), [ib1;ib2;ib3])
2078 | (_, ((B.DesignatorField _|B.DesignatorIndex _|B.DesignatorRange _), _)) ->
2082 and initialisers = fun ias (ibs, iicomma) ->
2083 let ias_unsplit = unsplit_icomma ias in
2084 let ibs_split = resplit_initialiser ibs iicomma in
2087 if need_unordered_initialisers ibs
2088 then initialisers_unordered2
2089 else initialisers_ordered2
2091 f ias_unsplit ibs_split >>=
2092 (fun ias_unsplit ibs_split ->
2094 split_icomma ias_unsplit,
2095 unsplit_initialiser ibs_split
2099 (* todo: one day julia will reput a IDots *)
2100 and initialisers_ordered2 = fun ias ibs ->
2102 | [], [] -> return ([], [])
2103 | (x, xcomma)::xs, (y, commay)::ys ->
2104 (match A.unwrap xcomma with
2105 | A.IComma commax ->
2106 tokenf commax commay >>= (fun commax commay ->
2107 initialiser x y >>= (fun x y ->
2108 initialisers_ordered2 xs ys >>= (fun xs ys ->
2110 (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
2114 | _ -> raise Impossible (* unsplit_iicomma wrong *)
2120 and initialisers_unordered2 = fun ias ibs ->
2123 | [], ys -> return ([], ys)
2124 | (x,xcomma)::xs, ys ->
2126 let permut = Common.uncons_permut_lazy ys in
2127 permut +> List.fold_left (fun acc ((e, pos), rest) ->
2130 (match A.unwrap xcomma, e with
2131 | A.IComma commax, (y, commay) ->
2132 tokenf commax commay >>= (fun commax commay ->
2133 initialiser x y >>= (fun x y ->
2135 (x, (A.IComma commax) +> A.rewrap xcomma),
2139 | _ -> raise Impossible (* unsplit_iicomma wrong *)
2142 let rest = Lazy.force rest in
2143 initialisers_unordered2 xs rest >>= (fun xs rest ->
2146 Common.insert_elem_pos (e, pos) rest
2151 (* ------------------------------------------------------------------------- *)
2152 and (struct_fields: (A.declaration list, B.field list) matcher) =
2155 | [], [] -> return ([], [])
2156 | [], eb::ebs -> fail
2158 X.all_bound (A.get_inherited ea) >&&>
2159 (match A.unwrap ea, ebs with
2160 | A.Ddots (mcode, optwhen), ys ->
2161 if optwhen <> None then failwith "not handling when in argument";
2163 (* '...' can take more or less the beginnings of the arguments *)
2164 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
2165 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
2170 if mcode_contain_plus (mcodekind mcode)
2172 (* failwith "I have no token that I could accroche myself on" *)
2173 else return (dots2metavar mcode, [])
2176 X.distrf_struct_fields (dots2metavar mcode) startxs
2177 ) >>= (fun mcode startxs ->
2178 let mcode = metavar2dots mcode in
2179 struct_fields eas endxs >>= (fun eas endxs ->
2181 (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
2186 | _unwrapx, eb::ebs ->
2187 struct_field ea eb >>= (fun ea eb ->
2188 struct_fields eas ebs >>= (fun eas ebs ->
2189 return (ea::eas, eb::ebs)
2192 | _unwrapx, [] -> fail
2195 and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
2196 let (xfield, iifield) = fb in
2199 | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
2201 let iiptvirgb = tuple_of_list1 iiptvirg in
2203 (match onefield_multivars with
2204 | [] -> raise Impossible
2205 | [onevar,iivirg] ->
2206 assert (null iivirg);
2208 | B.BitField (sopt, typb, expr), ii ->
2209 pr2_once "warning: bitfield not handled by ast_cocci";
2211 | B.Simple (None, typb), ii ->
2212 pr2_once "warning: unamed struct field not handled by ast_cocci";
2214 | B.Simple (Some idb, typb), ii ->
2215 let (iidb) = tuple_of_list1 ii in
2217 (* build a declaration from a struct field *)
2218 let allminus = false in
2220 let stob = B.NoSto, false in
2222 ({B.v_namei = Some ((idb, None),[iidb]);
2225 B.v_local = Ast_c.NotLocalDecl;
2226 B.v_attr = Ast_c.noattr;
2230 onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
2231 (fun fa (var,iiptvirgb,iisto) ->
2234 | ({B.v_namei = Some ((idb, None),[iidb]);
2238 let onevar = B.Simple (Some idb, typb), [iidb] in
2242 ((B.DeclarationField
2243 (B.FieldDeclList ([onevar, iivirg], [iiptvirgb]))),
2246 | _ -> raise Impossible
2251 pr2_once "PB: More that one variable in decl. Have to split";
2255 let _iiptvirgb = tuple_of_list1 iifield in
2258 | B.MacroStructDeclTodo -> fail
2259 | B.CppDirectiveStruct directive -> fail
2260 | B.IfdefStruct directive -> fail
2264 (* ------------------------------------------------------------------------- *)
2265 and (fullType: (A.fullType, Ast_c.fullType) matcher) =
2267 X.optional_qualifier_flag (fun optional_qualifier ->
2268 X.all_bound (A.get_inherited typa) >&&>
2269 match A.unwrap typa, typb with
2270 | A.Type(cv,ty1), ((qu,il),ty2) ->
2272 if qu.B.const && qu.B.volatile
2275 ("warning: the type is both const & volatile but cocci " ^
2276 "does not handle that");
2278 (* Drop out the const/volatile part that has been matched.
2279 * This is because a SP can contain const T v; in which case
2280 * later in match_t_t when we encounter a T, we must not add in
2281 * the environment the whole type.
2286 (* "iso-by-absence" *)
2289 fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
2291 (A.Type(None, ty1)) +> A.rewrap typa,
2295 (match optional_qualifier, qu.B.const || qu.B.volatile with
2296 | false, false -> do_stuff ()
2297 | false, true -> fail
2298 | true, false -> do_stuff ()
2301 then pr2_once "USING optional_qualifier builtin isomorphism";
2307 (* todo: can be __const__ ? can be const & volatile so
2308 * should filter instead ?
2310 (match term x, il with
2311 | A.Const, [i1] when qu.B.const ->
2313 tokenf x i1 >>= (fun x i1 ->
2314 fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
2316 (A.Type(Some x, ty1)) +> A.rewrap typa,
2320 | A.Volatile, [i1] when qu.B.volatile ->
2321 tokenf x i1 >>= (fun x i1 ->
2322 fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
2324 (A.Type(Some x, ty1)) +> A.rewrap typa,
2332 | A.DisjType typas, typb ->
2334 List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
2336 | A.OptType(_), _ | A.UniqueType(_), _
2337 -> failwith "not handling Opt/Unique on type"
2342 * Why not (A.typeC, Ast_c.typeC) matcher ?
2343 * because when there is MetaType, we want that T record the whole type,
2344 * including the qualifier, and so this type (and the new_il function in
2345 * preceding function).
2348 and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
2350 X.all_bound (A.get_inherited ta) >&&>
2351 match A.unwrap ta, tb with
2354 | A.MetaType(ida,keep, inherited), typb ->
2356 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
2357 X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
2358 X.distrf_type ida typb >>= (fun ida typb ->
2360 A.MetaType(ida,keep, inherited) +> A.rewrap ta,
2364 | unwrap, (qub, typb) ->
2365 typeC ta typb >>= (fun ta typb ->
2366 return (ta, (qub, typb))
2369 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda =
2370 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2371 * And even if in baseb we have a Signed Int, that does not mean
2372 * that ii is of length 2, cos Signed is the default, so if in signa
2373 * we have Signed explicitely ? we cant "accrocher" this mcode to
2374 * something :( So for the moment when there is signed in cocci,
2375 * we force that there is a signed in c too (done in pattern.ml).
2377 let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
2380 (* handle some iso on type ? (cf complex C rule for possible implicit
2382 match basea, baseb with
2383 | A.VoidType, B.Void
2384 | A.FloatType, B.FloatType (B.CFloat)
2385 | A.DoubleType, B.FloatType (B.CDouble) ->
2386 assert (signaopt = None);
2387 let stringa = tuple_of_list1 stringsa in
2388 let (ibaseb) = tuple_of_list1 ii in
2389 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2391 (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
2392 (B.BaseType baseb, [ibaseb])
2395 | A.CharType, B.IntType B.CChar when signaopt = None ->
2396 let stringa = tuple_of_list1 stringsa in
2397 let ibaseb = tuple_of_list1 ii in
2398 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2400 (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
2401 (B.BaseType (B.IntType B.CChar), [ibaseb])
2404 | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
2405 let stringa = tuple_of_list1 stringsa in
2406 let ibaseb = tuple_of_list1 iibaseb in
2407 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2408 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2410 (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
2411 (B.BaseType (baseb), iisignbopt ++ [ibaseb])
2414 | A.ShortType, B.IntType (B.Si (_, B.CShort))
2415 | A.IntType, B.IntType (B.Si (_, B.CInt))
2416 | A.LongType, B.IntType (B.Si (_, B.CLong)) ->
2417 let stringa = tuple_of_list1 stringsa in
2420 (* iso-by-presence ? *)
2421 (* when unsigned int in SP, allow have just unsigned in C ? *)
2422 if mcode_contain_plus (mcodekind stringa)
2426 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2428 (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
2429 (B.BaseType (baseb), iisignbopt ++ [])
2435 "warning: long int or short int not handled by ast_cocci";
2439 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2440 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2442 (rebuilda ([stringa], signaopt)) +> A.rewrap ta,
2443 (B.BaseType (baseb), iisignbopt ++ [ibaseb])
2445 | _ -> raise Impossible
2450 | A.LongLongType, B.IntType (B.Si (_, B.CLongLong)) ->
2451 let (string1a,string2a) = tuple_of_list2 stringsa in
2453 [ibase1b;ibase2b] ->
2454 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2455 tokenf string1a ibase1b >>= (fun base1a ibase1b ->
2456 tokenf string2a ibase2b >>= (fun base2a ibase2b ->
2458 (rebuilda ([base1a;base2a], signaopt)) +> A.rewrap ta,
2459 (B.BaseType (baseb), iisignbopt ++ [ibase1b;ibase2b])
2461 | [] -> fail (* should something be done in this case? *)
2462 | _ -> raise Impossible)
2465 | _, B.FloatType B.CLongDouble
2468 "warning: long double not handled by ast_cocci";
2471 | _, (B.Void|B.FloatType _|B.IntType _) -> fail
2473 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda =
2474 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2475 * And even if in baseb we have a Signed Int, that does not mean
2476 * that ii is of length 2, cos Signed is the default, so if in signa
2477 * we have Signed explicitely ? we cant "accrocher" this mcode to
2478 * something :( So for the moment when there is signed in cocci,
2479 * we force that there is a signed in c too (done in pattern.ml).
2481 let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
2483 let match_to_type rebaseb =
2484 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2485 let ibaseb = tuple_of_list1 iibaseb in
2486 let fta = A.rewrap basea (A.Type(None,basea)) in
2487 let ftb = Ast_c.nQ,(B.BaseType (rebaseb), [ibaseb]) in
2488 fullType fta ftb >>= (fun fta (_,tb) ->
2489 (match A.unwrap fta,tb with
2490 A.Type(_,basea), (B.BaseType baseb, ii) ->
2491 let ibaseb = tuple_of_list1 ii in
2493 (rebuilda (basea, signaopt)) +> A.rewrap ta,
2494 (B.BaseType (baseb), iisignbopt ++ [ibaseb])
2496 | _ -> failwith "not possible"))) in
2498 (* handle some iso on type ? (cf complex C rule for possible implicit
2501 | B.IntType (B.Si (_sign, B.CChar2)) ->
2502 match_to_type (B.IntType B.CChar)
2504 | B.IntType (B.Si (_, ty)) ->
2506 | [] -> fail (* metavariable has to match something *)
2510 "warning: long int or short int not handled by ast_cocci";
2513 | [ibaseb] -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
2514 | _ -> raise Impossible
2518 | (B.Void|B.FloatType _|B.IntType _) -> fail
2520 and (typeC: (A.typeC, Ast_c.typeC) matcher) =
2522 match A.unwrap ta, tb with
2523 | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
2524 simulate_signed ta basea stringsa None tb baseb ii
2525 (function (stringsa, signaopt) -> A.BaseType (basea,stringsa))
2526 | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
2527 (match A.unwrap basea with
2528 A.BaseType (basea1,strings1) ->
2529 simulate_signed ta basea1 strings1 (Some signaopt) tb baseb ii
2530 (function (strings1, Some signaopt) ->
2533 Some (A.rewrap basea (A.BaseType (basea1,strings1))))
2534 | _ -> failwith "not possible")
2535 | A.MetaType(ida,keep,inherited) ->
2536 simulate_signed_meta ta basea (Some signaopt) tb baseb ii
2537 (function (basea, Some signaopt) ->
2538 A.SignedT(signaopt,Some basea)
2539 | _ -> failwith "not possible")
2540 | _ -> failwith "not possible")
2541 | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
2542 let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
2543 (match iibaseb, baseb with
2544 | [], B.IntType (B.Si (_sign, B.CInt)) ->
2545 sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
2547 | None -> raise Impossible
2550 (A.SignedT (signa,None)) +> A.rewrap ta,
2551 (B.BaseType baseb, iisignbopt)
2559 (* todo? iso with array *)
2560 | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
2561 let (ibmult) = tuple_of_list1 ii in
2562 fullType typa typb >>= (fun typa typb ->
2563 tokenf iamult ibmult >>= (fun iamult ibmult ->
2565 (A.Pointer (typa, iamult)) +> A.rewrap ta,
2566 (B.Pointer typb, [ibmult])
2569 | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
2570 (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
2572 let (lpb, rpb) = tuple_of_list2 ii in
2576 ("Not handling well variable length arguments func. "^
2577 "You have been warned");
2578 tokenf lpa lpb >>= (fun lpa lpb ->
2579 tokenf rpa rpb >>= (fun rpa rpb ->
2580 fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
2581 parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
2582 (fun paramsaundots paramsb ->
2583 let paramsa = redots paramsa paramsaundots in
2585 (A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
2586 (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
2594 | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
2595 (B.ParenType t1, ii) ->
2596 let (lp1b, rp1b) = tuple_of_list2 ii in
2597 let (qu1b, t1b) = t1 in
2599 | B.Pointer t2, ii ->
2600 let (starb) = tuple_of_list1 ii in
2601 let (qu2b, t2b) = t2 in
2603 | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
2604 let (lp2b, rp2b) = tuple_of_list2 ii in
2609 ("Not handling well variable length arguments func. "^
2610 "You have been warned");
2612 fullType tya tyb >>= (fun tya tyb ->
2613 tokenf lp1a lp1b >>= (fun lp1a lp1b ->
2614 tokenf rp1a rp1b >>= (fun rp1a rp1b ->
2615 tokenf lp2a lp2b >>= (fun lp2a lp2b ->
2616 tokenf rp2a rp2b >>= (fun rp2a rp2b ->
2617 tokenf stara starb >>= (fun stara starb ->
2618 parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
2619 (fun paramsaundots paramsb ->
2620 let paramsa = redots paramsa paramsaundots in
2624 (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
2629 (B.Pointer t2, [starb]))
2633 (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
2635 (B.ParenType t1, [lp1b;rp1b])
2648 (* todo: handle the iso on optionnal size specifification ? *)
2649 | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
2650 let (ib1, ib2) = tuple_of_list2 ii in
2651 fullType typa typb >>= (fun typa typb ->
2652 option expression eaopt ebopt >>= (fun eaopt ebopt ->
2653 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
2654 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
2656 (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
2657 (B.Array (ebopt, typb), [ib1;ib2])
2661 (* todo: could also match a Struct that has provided a name *)
2662 (* This is for the case where the SmPL code contains "struct x", without
2663 a definition. In this case, the name field is always present.
2664 This case is also called from the case for A.StructUnionDef when
2665 a name is present in the C code. *)
2666 | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
2667 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2668 let (ib1, ib2) = tuple_of_list2 ii in
2669 if equal_structUnion (term sua) sub
2671 ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
2672 tokenf sua ib1 >>= (fun sua ib1 ->
2674 (A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
2675 (B.StructUnionName (sub, sb), [ib1;ib2])
2680 | A.StructUnionDef(ty, lba, declsa, rba),
2681 (B.StructUnion (sub, sbopt, declsb), ii) ->
2683 let (ii_sub_sb, lbb, rbb) =
2685 [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
2686 | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
2687 | _ -> failwith "list of length 3 or 4 expected" in
2690 match (sbopt,ii_sub_sb) with
2691 (None,Common.Left iisub) ->
2692 (* the following doesn't reconstruct the complete SP code, just
2693 the part that matched *)
2695 match A.unwrap s with
2697 (match A.unwrap ty with
2698 A.StructUnionName(sua, None) ->
2699 tokenf sua iisub >>= (fun sua iisub ->
2702 A.StructUnionName(sua, None) +> A.rewrap ty)
2704 return (ty,[iisub]))
2706 | A.DisjType(disjs) ->
2708 List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
2712 | (Some sb,Common.Right (iisub,iisb)) ->
2714 (* build a StructUnionName from a StructUnion *)
2715 let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
2717 fullType ty fake_su >>= (fun ty fake_su ->
2719 | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
2720 return (ty, [iisub; iisb])
2721 | _ -> raise Impossible)
2725 >>= (fun ty ii_sub_sb ->
2727 tokenf lba lbb >>= (fun lba lbb ->
2728 tokenf rba rbb >>= (fun rba rbb ->
2729 struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
2730 let declsa = redots declsa undeclsa in
2733 (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
2734 (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
2738 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2739 * uint in the C code. But some CEs consists in renaming some types,
2740 * so we don't want apply isomorphisms every time.
2742 | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
2743 let (isb) = tuple_of_list1 ii in
2746 tokenf sa isb >>= (fun sa isb ->
2748 (A.TypeName sa) +> A.rewrap ta,
2749 (B.TypeName (sb,typb), [isb])
2753 | _, (B.TypeOfExpr e, ii) -> fail
2754 | _, (B.TypeOfType e, ii) -> fail
2756 | _, (B.ParenType e, ii) -> fail (* todo ?*)
2757 | A.EnumName(en,namea), (B.EnumName nameb, ii) ->
2758 let (ib1,ib2) = tuple_of_list2 ii in
2759 ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
2760 tokenf en ib1 >>= (fun en ib1 ->
2762 (A.EnumName (en, namea)) +> A.rewrap ta,
2763 (B.EnumName nameb, [ib1;ib2])
2766 | _, (B.Enum _, _) -> fail (* todo cocci ?*)
2769 ((B.TypeName (_, _) | B.StructUnionName (_, _) | B.EnumName _ |
2770 B.StructUnion (_, _, _) |
2771 B.FunctionType _ | B.Array (_, _) | B.Pointer _ |
2777 (* todo: iso on sign, if not mentioned then free. tochange?
2778 * but that require to know if signed int because explicit
2779 * signed int, or because implicit signed int.
2782 and sign signa signb =
2783 match signa, signb with
2784 | None, None -> return (None, [])
2785 | Some signa, Some (signb, ib) ->
2786 if equal_sign (term signa) signb
2787 then tokenf signa ib >>= (fun signa ib ->
2788 return (Some signa, [ib])
2794 and minusize_list iixs =
2795 iixs +> List.fold_left (fun acc ii ->
2796 acc >>= (fun xs ys ->
2797 tokenf minusizer ii >>= (fun minus ii ->
2798 return (minus::xs, ii::ys)
2799 ))) (return ([],[]))
2800 >>= (fun _xsminys ys ->
2801 return ((), List.rev ys)
2804 and storage_optional_allminus allminus stoa (stob, iistob) =
2805 (* "iso-by-absence" for storage, and return type. *)
2806 X.optional_storage_flag (fun optional_storage ->
2807 match stoa, stob with
2808 | None, (stobis, inline) ->
2812 minusize_list iistob >>= (fun () iistob ->
2813 return (None, (stob, iistob))
2815 else return (None, (stob, iistob))
2818 (match optional_storage, stobis with
2819 | false, B.NoSto -> do_minus ()
2821 | true, B.NoSto -> do_minus ()
2824 then pr2_once "USING optional_storage builtin isomorphism";
2828 | Some x, ((stobis, inline)) ->
2829 if equal_storage (term x) stobis
2833 tokenf x i1 >>= (fun x i1 ->
2834 return (Some x, ((stobis, inline), [i1]))
2836 (* or if have inline ? have to do a split_storage_inline a la
2837 * split_signb_baseb_ii *)
2838 | _ -> raise Impossible
2846 and fullType_optional_allminus allminus tya retb =
2851 X.distrf_type minusizer retb >>= (fun _x retb ->
2855 else return (None, retb)
2857 fullType tya retb >>= (fun tya retb ->
2858 return (Some tya, retb)
2863 (*---------------------------------------------------------------------------*)
2865 and compatible_base_type a signa b =
2866 let ok = return ((),()) in
2869 | Type_cocci.VoidType, B.Void ->
2870 assert (signa = None);
2872 | Type_cocci.CharType, B.IntType B.CChar when signa = None ->
2874 | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
2875 compatible_sign signa signb
2876 | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
2877 compatible_sign signa signb
2878 | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
2879 compatible_sign signa signb
2880 | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
2881 compatible_sign signa signb
2882 | _, B.IntType (B.Si (signb, B.CLongLong)) ->
2883 pr2_once "no longlong in cocci";
2885 | Type_cocci.FloatType, B.FloatType B.CFloat ->
2886 assert (signa = None);
2888 | Type_cocci.DoubleType, B.FloatType B.CDouble ->
2889 assert (signa = None);
2891 | _, B.FloatType B.CLongDouble ->
2892 pr2_once "no longdouble in cocci";
2894 | Type_cocci.BoolType, _ -> failwith "no booltype in C"
2896 | _, (B.Void|B.FloatType _|B.IntType _) -> fail
2898 and compatible_base_type_meta a signa qua b ii local =
2900 | Type_cocci.MetaType(ida,keep,inherited),
2901 B.IntType (B.Si (signb, B.CChar2)) ->
2902 compatible_sign signa signb >>= fun _ _ ->
2903 let newb = ((qua, (B.BaseType (B.IntType B.CChar),ii)),local) in
2904 compatible_type a newb
2905 | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
2906 compatible_sign signa signb >>= fun _ _ ->
2908 ((qua, (B.BaseType (B.IntType (B.Si (B.Signed, ty))),ii)),local) in
2909 compatible_type a newb
2910 | _, B.FloatType B.CLongDouble ->
2911 pr2_once "no longdouble in cocci";
2914 | _, (B.Void|B.FloatType _|B.IntType _) -> fail
2917 and compatible_type a (b,local) =
2918 let ok = return ((),()) in
2920 let rec loop = function
2921 | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
2922 compatible_base_type a None b
2924 | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
2925 compatible_base_type Type_cocci.IntType (Some signa) b
2927 | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
2929 Type_cocci.BaseType ty ->
2930 compatible_base_type ty (Some signa) b
2931 | Type_cocci.MetaType(ida,keep,inherited) ->
2932 compatible_base_type_meta ty (Some signa) qua b ii local
2933 | _ -> failwith "not possible")
2935 | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
2937 | Type_cocci.FunctionPointer a, _ ->
2939 "TODO: function pointer type doesn't store enough information to determine compatability"
2940 | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
2941 (* no size info for cocci *)
2943 | Type_cocci.StructUnionName (sua, _, sa),
2944 (qub, (B.StructUnionName (sub, sb),ii)) ->
2945 if equal_structUnion_type_cocci sua sub && sa = sb
2948 | Type_cocci.EnumName (_, sa),
2949 (qub, (B.EnumName (sb),ii)) ->
2953 | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
2958 | Type_cocci.ConstVol (qua, a), (qub, b) ->
2959 if (fst qub).B.const && (fst qub).B.volatile
2962 pr2_once ("warning: the type is both const & volatile but cocci " ^
2963 "does not handle that");
2969 | Type_cocci.Const -> (fst qub).B.const
2970 | Type_cocci.Volatile -> (fst qub).B.volatile
2972 then loop (a,(Ast_c.nQ, b))
2975 | Type_cocci.MetaType (ida,keep,inherited), typb ->
2977 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
2978 X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
2982 (* subtil: must be after the MetaType case *)
2983 | a, (qub, (B.TypeName (sb,Some b), ii)) ->
2984 (* kind of typedef iso *)
2991 (* for metavariables of type expression *^* *)
2992 | Type_cocci.Unknown , _ -> ok
2997 B.TypeOfType _|B.TypeOfExpr _|B.ParenType _|
2998 B.EnumName _|B.StructUnion (_, _, _)|B.Enum (_, _)
3005 B.StructUnionName (_, _)|
3007 B.Array (_, _)|B.Pointer _|B.TypeName _|
3016 and compatible_sign signa signb =
3017 let ok = return ((),()) in
3018 match signa, signb with
3020 | Some Type_cocci.Signed, B.Signed
3021 | Some Type_cocci.Unsigned, B.UnSigned
3026 and equal_structUnion_type_cocci a b =
3028 | Type_cocci.Struct, B.Struct -> true
3029 | Type_cocci.Union, B.Union -> true
3030 | _, (B.Struct | B.Union) -> false
3034 (*---------------------------------------------------------------------------*)
3035 and inc_file (a, before_after) (b, h_rel_pos) =
3037 let rec aux_inc (ass, bss) passed =
3041 let passed = List.rev passed in
3043 (match before_after, !h_rel_pos with
3044 | IncludeNothing, _ -> true
3045 | IncludeMcodeBefore, Some x ->
3046 List.mem passed (x.Ast_c.first_of)
3048 | IncludeMcodeAfter, Some x ->
3049 List.mem passed (x.Ast_c.last_of)
3051 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3055 | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
3056 | _ -> failwith "IncDots not in last place or other pb"
3061 | A.Local ass, B.Local bss ->
3062 aux_inc (ass, bss) []
3063 | A.NonLocal ass, B.NonLocal bss ->
3064 aux_inc (ass, bss) []
3069 (*---------------------------------------------------------------------------*)
3071 and (define_params: sequence ->
3072 (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
3073 fun seqstyle eas ebs ->
3075 | Unordered -> failwith "not handling ooo"
3077 define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
3078 return (eas, (Ast_c.unsplit_comma ebs_splitted))
3081 (* todo? facto code with argument and parameters ? *)
3082 and define_paramsbis = fun eas ebs ->
3084 | [], [] -> return ([], [])
3085 | [], eb::ebs -> fail
3087 X.all_bound (A.get_inherited ea) >&&>
3088 (match A.unwrap ea, ebs with
3089 | A.DPdots (mcode), ys ->
3091 (* '...' can take more or less the beginnings of the arguments *)
3092 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
3093 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
3098 if mcode_contain_plus (mcodekind mcode)
3100 (* failwith "I have no token that I could accroche myself on" *)
3101 else return (dots2metavar mcode, [])
3103 (match Common.last startxs with
3106 X.distrf_define_params (dots2metavar mcode) startxs
3108 ) >>= (fun mcode startxs ->
3109 let mcode = metavar2dots mcode in
3110 define_paramsbis eas endxs >>= (fun eas endxs ->
3112 (A.DPdots (mcode) +> A.rewrap ea) ::eas,
3118 | A.DPComma ia1, Right ii::ebs ->
3119 let ib1 = tuple_of_list1 ii in
3120 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3121 define_paramsbis eas ebs >>= (fun eas ebs ->
3123 (A.DPComma ia1 +> A.rewrap ea)::eas,
3128 | A.DPComma ia1, ebs ->
3129 if mcode_contain_plus (mcodekind ia1)
3132 (define_paramsbis eas ebs) (* try optional comma trick *)
3134 | (A.OptDParam _ | A.UniqueDParam _), _ ->
3135 failwith "handling Opt/Unique for define parameters"
3137 | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
3139 | A.DParam ida, (Left (idb, ii))::ebs ->
3140 let ib1 = tuple_of_list1 ii in
3141 ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
3142 define_paramsbis eas ebs >>= (fun eas ebs ->
3144 (A.DParam ida)+> A.rewrap ea :: eas,
3145 (Left (idb, [ib1]))::ebs
3148 | _unwrapx, (Right y)::ys -> raise Impossible
3149 | _unwrapx, [] -> fail
3154 (*****************************************************************************)
3156 (*****************************************************************************)
3158 (* no global solution for positions here, because for a statement metavariable
3159 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3161 let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
3164 x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
3166 X.all_bound (A.get_inherited re) >&&>
3169 match A.unwrap re, F.unwrap node with
3171 (* note: the order of the clauses is important. *)
3173 | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
3175 (* the metaRuleElem contains just '-' information. We dont need to add
3176 * stuff in the environment. If we need stuff in environment, because
3177 * there is a + S somewhere, then this will be done via MetaStmt, not
3179 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3182 | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
3183 let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
3184 (match unwrap_node with
3186 | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
3188 if X.mode = PatternMode
3191 if mcode_contain_plus (mcodekind mcode)
3192 then failwith "try add stuff on fake node"
3193 (* minusize or contextize a fake node is ok *)
3196 | F.EndStatement None ->
3197 if X.mode = PatternMode then return default
3199 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3200 if mcode_contain_plus (mcodekind mcode)
3202 let fake_info = Ast_c.fakeInfo() in
3203 distrf distrf_node (mcodekind mcode)
3204 (F.EndStatement (Some fake_info))
3205 else return unwrap_node
3209 | F.EndStatement (Some i1) ->
3210 tokenf mcode i1 >>= (fun mcode i1 ->
3212 A.MetaRuleElem (mcode,keep, inherited),
3213 F.EndStatement (Some i1)
3217 if X.mode = PatternMode then return default
3218 else failwith "a MetaRuleElem can't transform a headfunc"
3220 if X.mode = PatternMode then return default
3222 X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
3224 A.MetaRuleElem(mcode,keep, inherited),
3230 (* rene cant have found that a state containing a fake/exit/... should be
3232 * TODO: and F.Fake ?
3234 | _, F.EndStatement _ | _, F.CaseNode _
3235 | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
3239 (* really ? diff between pattern.ml and transformation.ml *)
3240 | _, F.Fake -> fail2()
3243 (* cas general: a Meta can match everything. It matches only
3244 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3245 * So can't have been called in transform.
3247 | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
3249 | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
3250 (* todo: should not happen in transform mode *)
3252 (match Control_flow_c.extract_fullstatement node with
3255 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
3256 X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
3258 (* no need tag ida, we can't be called in transform-mode *)
3260 A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
3268 | A.MetaStmtList _, _ ->
3269 failwith "not handling MetaStmtList"
3271 | A.TopExp ea, F.DefineExpr eb ->
3272 expression ea eb >>= (fun ea eb ->
3278 | A.TopExp ea, F.DefineType eb ->
3279 (match A.unwrap ea with
3281 fullType ft eb >>= (fun ft eb ->
3283 A.TopExp (A.rewrap ea (A.TypeExp(ft))),
3290 (* It is important to put this case before the one that fails because
3291 * of the lack of the counter part of a C construct in SmPL (for instance
3292 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3293 * yet certain constructs, those constructs may contain expression
3294 * that we still want and can transform.
3297 | A.Exp exp, nodeb ->
3299 (* kind of iso, initialisation vs affectation *)
3301 match A.unwrap exp, nodeb with
3302 | A.Assignment (ea, op, eb, true), F.Decl decl ->
3303 initialisation_to_affectation decl +> F.rewrap node
3308 (* Now keep fullstatement inside the control flow node,
3309 * so that can then get in a MetaStmtVar the fullstatement to later
3310 * pp back when the S is in a +. But that means that
3311 * Exp will match an Ifnode even if there is no such exp
3312 * inside the condition of the Ifnode (because the exp may
3313 * be deeper, in the then branch). So have to not visit
3314 * all inside a node anymore.
3316 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3317 * fois le fullstatement et le partialstatement et appeler le
3318 * visiteur que sur le partialstatement.
3321 match Ast_cocci.get_pos re with
3322 | None -> expression
3326 Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
3327 let keep = Type_cocci.Unitary in
3328 let inherited = false in
3329 let max_min _ = failwith "no pos" in
3330 X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
3336 X.cocciExp expfn exp node >>= (fun exp node ->
3344 X.cocciTy fullType ty node >>= (fun ty node ->
3351 | A.TopInit init, nodeb ->
3352 X.cocciInit initialiser init node >>= (fun init node ->
3360 | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
3361 F.FunHeader ({B.f_name = idb;
3362 f_type = (retb, (paramsb, (isvaargs, iidotsb)));
3366 f_old_c_style = oldstyle;
3371 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3374 (* fninfoa records the order in which the SP specified the various
3375 information, but this isn't taken into account in the matching.
3376 Could this be a problem for transformation? *)
3379 List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
3380 with [A.FStorage(s)] -> Some s | _ -> None in
3382 match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
3383 with [A.FType(t)] -> Some t | _ -> None in
3385 (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
3386 with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
3388 (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
3389 with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
3392 | iidb::ioparenb::icparenb::iifakestart::iistob ->
3394 (* maybe important to put ident as the first tokens to transform.
3395 * It's related to transform_proto. So don't change order
3398 ident LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
3399 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
3400 tokenf oparen ioparenb >>= (fun oparen ioparenb ->
3401 tokenf cparen icparenb >>= (fun cparen icparenb ->
3402 parameters (seqstyle paramsa)
3403 (A.undots paramsa) paramsb >>=
3404 (fun paramsaundots paramsb ->
3405 let paramsa = redots paramsa paramsaundots in
3406 storage_optional_allminus allminus
3407 stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
3412 ("Not handling well variable length arguments func. "^
3413 "You have been warned");
3415 then minusize_list iidotsb
3416 else return ((),iidotsb)
3417 ) >>= (fun () iidotsb ->
3419 fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
3422 (match stoa with Some st -> [A.FStorage st] | None -> []) ++
3423 (match tya with Some t -> [A.FType t] | None -> [])
3428 A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
3430 F.FunHeader ({B.f_name = idb;
3431 f_type = (retb, (paramsb, (isvaargs, iidotsb)));
3435 f_old_c_style = oldstyle; (* TODO *)
3437 iidb::ioparenb::icparenb::iifakestart::iistob)
3440 | _ -> raise Impossible
3448 | A.Decl (mckstart,allminus,decla), F.Decl declb ->
3449 declaration (mckstart,allminus,decla) declb >>=
3450 (fun (mckstart,allminus,decla) declb ->
3452 A.Decl (mckstart,allminus,decla),
3457 | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
3458 tokenf mcode i1 >>= (fun mcode i1 ->
3461 F.SeqStart (st, level, i1)
3464 | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
3465 tokenf mcode i1 >>= (fun mcode i1 ->
3468 F.SeqEnd (level, i1)
3471 | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
3472 let ib1 = tuple_of_list1 ii in
3473 expression ea eb >>= (fun ea eb ->
3474 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3476 A.ExprStatement (ea, ia1),
3477 F.ExprStatement (st, (Some eb, [ib1]))
3482 | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
3483 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3484 expression ea eb >>= (fun ea eb ->
3485 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3486 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3487 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3489 A.IfHeader (ia1, ia2, ea, ia3),
3490 F.IfHeader (st, (eb,[ib1;ib2;ib3]))
3493 | A.Else ia, F.Else ib ->
3494 tokenf ia ib >>= (fun ia ib ->
3495 return (A.Else ia, F.Else ib)
3498 | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
3499 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3500 expression ea eb >>= (fun ea eb ->
3501 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3502 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3503 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3505 A.WhileHeader (ia1, ia2, ea, ia3),
3506 F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
3509 | A.DoHeader ia, F.DoHeader (st, ib) ->
3510 tokenf ia ib >>= (fun ia ib ->
3515 | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
3516 let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
3517 expression ea eb >>= (fun ea eb ->
3518 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3519 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3520 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3521 tokenf ia4 ib4 >>= (fun ia4 ib4 ->
3523 A.WhileTail (ia1,ia2,ea,ia3,ia4),
3524 F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
3526 | A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
3528 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3530 ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
3531 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3532 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3533 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
3534 let eas = redots eas easundots in
3536 A.IteratorHeader (ia1, ia2, eas, ia3),
3537 F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
3542 | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
3543 F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
3545 assert (null ib4vide);
3546 let (ib1, ib2, ib5) = tuple_of_list3 ii in
3547 let ib3 = tuple_of_list1 ib3s in
3548 let ib4 = tuple_of_list1 ib4s in
3550 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3551 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3552 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3553 tokenf ia4 ib4 >>= (fun ia4 ib4 ->
3554 tokenf ia5 ib5 >>= (fun ia5 ib5 ->
3555 option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
3556 option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
3557 option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
3559 A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
3560 F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
3566 | A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
3567 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3568 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3569 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3570 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3571 expression ea eb >>= (fun ea eb ->
3573 A.SwitchHeader(ia1,ia2,ea,ia3),
3574 F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
3577 | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
3578 let (ib1, ib2) = tuple_of_list2 ii in
3579 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3580 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3583 F.Break (st, ((),[ib1;ib2]))
3586 | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
3587 let (ib1, ib2) = tuple_of_list2 ii in
3588 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3589 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3591 A.Continue (ia1, ia2),
3592 F.Continue (st, ((),[ib1;ib2]))
3595 | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
3596 let (ib1, ib2) = tuple_of_list2 ii in
3597 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3598 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3600 A.Return (ia1, ia2),
3601 F.Return (st, ((),[ib1;ib2]))
3604 | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
3605 let (ib1, ib2) = tuple_of_list2 ii in
3606 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3607 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3608 expression ea eb >>= (fun ea eb ->
3610 A.ReturnExpr (ia1, ea, ia2),
3611 F.ReturnExpr (st, (eb, [ib1;ib2]))
3616 | A.Include(incla,filea),
3617 F.Include {B.i_include = (fileb, ii);
3618 B.i_rel_pos = h_rel_pos;
3619 B.i_is_in_ifdef = inifdef;
3622 assert (copt = None);
3624 let include_requirment =
3625 match mcodekind incla, mcodekind filea with
3626 | A.CONTEXT (_, A.BEFORE _), _ ->
3628 | _, A.CONTEXT (_, A.AFTER _) ->
3634 let (inclb, iifileb) = tuple_of_list2 ii in
3635 if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
3637 tokenf incla inclb >>= (fun incla inclb ->
3638 tokenf filea iifileb >>= (fun filea iifileb ->
3640 A.Include(incla, filea),
3641 F.Include {B.i_include = (fileb, [inclb;iifileb]);
3642 B.i_rel_pos = h_rel_pos;
3643 B.i_is_in_ifdef = inifdef;
3651 | A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
3652 let (defineb, iidb, ieol) = tuple_of_list3 ii in
3653 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
3654 tokenf definea defineb >>= (fun definea defineb ->
3655 (match A.unwrap params, defkind with
3656 | A.NoParams, B.DefineVar ->
3658 A.NoParams +> A.rewrap params,
3661 | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
3662 let (lpb, rpb) = tuple_of_list2 ii in
3663 tokenf lpa lpb >>= (fun lpa lpb ->
3664 tokenf rpa rpb >>= (fun rpa rpb ->
3666 define_params (seqstyle eas) (A.undots eas) ebs >>=
3667 (fun easundots ebs ->
3668 let eas = redots eas easundots in
3670 A.DParams (lpa,eas,rpa) +> A.rewrap params,
3671 B.DefineFunc (ebs,[lpb;rpb])
3675 ) >>= (fun params defkind ->
3677 A.DefineHeader (definea, ida, params),
3678 F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
3683 | A.Default(def,colon), F.Default (st, ((),ii)) ->
3684 let (ib1, ib2) = tuple_of_list2 ii in
3685 tokenf def ib1 >>= (fun def ib1 ->
3686 tokenf colon ib2 >>= (fun colon ib2 ->
3688 A.Default(def,colon),
3689 F.Default (st, ((),[ib1;ib2]))
3694 | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
3695 let (ib1, ib2) = tuple_of_list2 ii in
3696 tokenf case ib1 >>= (fun case ib1 ->
3697 expression ea eb >>= (fun ea eb ->
3698 tokenf colon ib2 >>= (fun colon ib2 ->
3700 A.Case(case,ea,colon),
3701 F.Case (st, (eb,[ib1;ib2]))
3704 (* only occurs in the predicates generated by asttomember *)
3705 | A.DisjRuleElem eas, _ ->
3707 List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
3708 >>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
3710 | _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
3712 | A.Label(id,dd), F.Label (st,(s,ii)) ->
3713 let (ib1,ib2) = tuple_of_list2 ii in
3714 let (string_of_id,rebuild) =
3715 match A.unwrap id with
3716 A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
3717 | _ -> failwith "labels with metavariables not supported" in
3718 if (term string_of_id) =$= s
3720 tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
3721 tokenf dd ib2 >>= (fun dd ib2 ->
3723 A.Label(rebuild string_of_id,dd),
3724 F.Label (st,(s,[ib1;ib2]))
3728 | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
3729 let (ib1,ib2,ib3) = tuple_of_list3 ii in
3730 tokenf goto ib1 >>= (fun goto ib1 ->
3731 ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
3732 tokenf sem ib3 >>= (fun sem ib3 ->
3734 A.Goto(goto,id,sem),
3735 F.Goto (st,(s,[ib1;ib2;ib3]))
3738 (* have not a counter part in coccinelle, for the moment *)
3739 (* todo?: print a warning at least ? *)
3745 | _, (F.IfdefEndif _|F.IfdefElse _|F.IfdefHeader _)
3749 (F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
3752 (F.Label (_, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
3753 F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
3754 F.DefineType _|F.DefineExpr _|F.DefineTodo|
3755 F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
3756 F.SwitchHeader (_, _)|F.ForHeader (_, _)|F.DoWhileTail _|F.DoHeader (_, _)|
3757 F.WhileHeader (_, _)|F.Else _|F.IfHeader (_, _)|
3758 F.SeqEnd (_, _)|F.SeqStart (_, _, _)|
3759 F.Decl _|F.FunHeader _)