2 * Copyright 2005-2008, 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 (*****************************************************************************)
32 (*****************************************************************************)
34 (*****************************************************************************)
36 (*****************************************************************************)
38 type sequence = Ordered | Unordered
41 match A.unwrap eas with
43 | A.CIRCLES _ -> Unordered
44 | A.STARS _ -> failwith "not handling stars"
46 let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
48 match A.unwrap eas with
49 | A.DOTS _ -> A.DOTS easundots
50 | A.CIRCLES _ -> A.CIRCLES easundots
51 | A.STARS _ -> A.STARS easundots
55 let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
57 ibs +> List.exists (fun (ib, icomma) ->
58 match B.unwrap ib with
68 (* For the #include <linux/...> in the .cocci, need to find where is
69 * the '+' attached to this element, to later find the first concrete
70 * #include <linux/xxx.h> or last one in the serie of #includes in the
73 type include_requirement =
80 (* todo? put in semantic_c.ml *)
83 | LocalFunction (* entails Function *)
87 let term mc = A.unwrap_mcode mc
88 let mcodekind mc = A.get_mcodekind mc
91 let mcode_contain_plus = function
92 | A.CONTEXT (_,A.NOTHING) -> false
94 | A.MINUS (_,[]) -> false
95 | A.MINUS (_,x::xs) -> true
96 | A.PLUS -> raise Impossible
98 let mcode_simple_minus = function
99 | A.MINUS (_,[]) -> true
103 (* In transformation.ml sometime I build some mcodekind myself and
104 * julia has put None for the pos. But there is no possible raise
105 * NoMatch in those cases because it is for the minusall trick or for
106 * the distribute, so either have to build those pos, in fact a range,
107 * because for the distribute have to erase a fullType with one
108 * mcodekind, or add an argument to tag_with_mck such as "safe" that
109 * don't do the check_pos. Hence this DontCarePos constructor. *)
113 {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
114 (A.MINUS(A.DontCarePos, [])),
117 let generalize_mcode ia =
118 let (s1, i, mck, pos) = ia in
121 | A.PLUS -> raise Impossible
122 | A.CONTEXT (A.NoPos,x) ->
123 A.CONTEXT (A.DontCarePos,x)
124 | A.MINUS (A.NoPos,x) ->
125 A.MINUS (A.DontCarePos,x)
126 | _ -> raise Impossible in
127 (s1, i, new_mck, pos)
131 (*---------------------------------------------------------------------------*)
133 (* 0x0 is equivalent to 0, value format isomorphism *)
134 let equal_c_int s1 s2 =
136 int_of_string s1 = int_of_string s2
137 with Failure("int_of_string") ->
142 (*---------------------------------------------------------------------------*)
143 (* Normally A should reuse some types of Ast_c, so those
144 * functions should not exist.
146 * update: but now Ast_c depends on A, so can't make too
147 * A depends on Ast_c, so have to stay with those equal_xxx
151 let equal_unaryOp a b =
153 | A.GetRef , B.GetRef -> true
154 | A.DeRef , B.DeRef -> true
155 | A.UnPlus , B.UnPlus -> true
156 | A.UnMinus , B.UnMinus -> true
157 | A.Tilde , B.Tilde -> true
158 | A.Not , B.Not -> true
161 let equal_arithOp a b =
163 | A.Plus , B.Plus -> true
164 | A.Minus , B.Minus -> true
165 | A.Mul , B.Mul -> true
166 | A.Div , B.Div -> true
167 | A.Mod , B.Mod -> true
168 | A.DecLeft , B.DecLeft -> true
169 | A.DecRight , B.DecRight -> true
170 | A.And , B.And -> true
171 | A.Or , B.Or -> true
172 | A.Xor , B.Xor -> true
175 let equal_logicalOp a b =
177 | A.Inf , B.Inf -> true
178 | A.Sup , B.Sup -> true
179 | A.InfEq , B.InfEq -> true
180 | A.SupEq , B.SupEq -> true
181 | A.Eq , B.Eq -> true
182 | A.NotEq , B.NotEq -> true
183 | A.AndLog , B.AndLog -> true
184 | A.OrLog , B.OrLog -> true
187 let equal_assignOp a b =
189 | A.SimpleAssign, B.SimpleAssign -> true
190 | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
193 let equal_fixOp a b =
195 | A.Dec, B.Dec -> true
196 | A.Inc, B.Inc -> true
199 let equal_binaryOp a b =
201 | A.Arith a, B.Arith b -> equal_arithOp a b
202 | A.Logical a, B.Logical b -> equal_logicalOp a b
205 let equal_structUnion a b =
207 | A.Struct, B.Struct -> true
208 | A.Union, B.Union -> true
213 | A.Signed, B.Signed -> true
214 | A.Unsigned, B.UnSigned -> true
217 let equal_storage a b =
219 | A.Static , B.Sto B.Static
220 | A.Auto , B.Sto B.Auto
221 | A.Register , B.Sto B.Register
222 | A.Extern , B.Sto B.Extern
226 (*---------------------------------------------------------------------------*)
228 let equal_metavarval valu valu' =
229 match valu, valu' with
230 | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
231 | Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
232 | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
233 (* do something more ? *)
236 (* al_expr before comparing !!! and accept when they match.
237 * Note that here we have Astc._expression, so it is a match
238 * modulo isomorphism (there is no metavariable involved here,
239 * just isomorphisms). => TODO call isomorphism_c_c instead of
240 * =*=. Maybe would be easier to transform ast_c in ast_cocci
241 * and call the iso engine of julia. *)
242 | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
243 Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
244 | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
245 Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
247 | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
248 Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
249 | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
250 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
253 | Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
255 | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
256 Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
257 | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
258 Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
260 | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
261 Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
263 | Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
265 (function (fla,posa1,posa2) ->
267 (function (flb,posb1,posb2) ->
269 Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
272 | _ -> raise Impossible
276 (*---------------------------------------------------------------------------*)
277 (* could put in ast_c.ml, next to the split/unsplit_comma *)
278 let split_signb_baseb_ii (baseb, ii) =
279 let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
280 match baseb, iis with
282 | B.Void, ["void",i1] -> None, [i1]
284 | B.FloatType (B.CFloat),["float",i1] -> None, [i1]
285 | B.FloatType (B.CDouble),["double",i1] -> None, [i1]
286 | B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
288 | B.IntType (B.CChar), ["char",i1] -> None, [i1]
291 | B.IntType (B.Si (sign, base)), xs ->
292 (match sign, base, xs with
293 | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
294 Some (B.Signed, i1), [i2]
295 | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
296 Some (B.UnSigned, i1), [i2]
298 | B.Signed, B.CShort, ["short",i1] ->
300 | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
301 Some (B.Signed, i1), [i2]
302 | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
303 Some (B.UnSigned, i1), [i2]
304 | B.Signed, B.CShort, ["short",i1;"int",i2] ->
307 | B.Signed, B.CInt, ["int",i1] ->
309 | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
310 Some (B.Signed, i1), [i2]
311 | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
312 Some (B.UnSigned, i1), [i2]
314 | B.Signed, B.CInt, ["signed",i1;] ->
315 Some (B.Signed, i1), []
316 | B.UnSigned, B.CInt, ["unsigned",i1;] ->
317 Some (B.UnSigned, i1), []
319 | B.Signed, B.CLong, ["long",i1] ->
321 | B.Signed, B.CLong, ["long",i1;"int",i2] ->
323 | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
324 Some (B.Signed, i1), [i2]
325 | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
326 Some (B.UnSigned, i1), [i2]
328 | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
329 | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
330 Some (B.Signed, i1), [i2;i3]
331 | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
332 Some (B.UnSigned, i1), [i2;i3]
335 | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
336 Some (B.UnSigned, i1), [i2;i3]
340 | _ -> failwith "strange type1, maybe because of weird order"
342 | _ -> failwith "strange type2, maybe because of weird order"
344 (*---------------------------------------------------------------------------*)
346 let rec unsplit_icomma xs =
350 (match A.unwrap y with
352 (x, y)::unsplit_icomma xs
353 | _ -> failwith "wrong ast_cocci in initializer"
356 failwith ("wrong ast_cocci in initializer, should have pair " ^
361 let resplit_initialiser ibs iicomma =
362 match iicomma, ibs with
365 failwith "should have a iicomma, do you generate fakeInfo in parser?"
367 failwith "shouldn't have a iicomma"
368 | [iicomma], x::xs ->
369 let elems = List.map fst (x::xs) in
370 let commas = List.map snd (x::xs) +> List.flatten in
371 let commas = commas @ [iicomma] in
373 | _ -> raise Impossible
377 let rec split_icomma xs =
380 | (x,y)::xs -> x::y::split_icomma xs
382 let rec unsplit_initialiser ibs_unsplit =
383 match ibs_unsplit with
384 | [] -> [], [] (* empty iicomma *)
386 let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
387 (x, [])::xs, lastcomma
389 and unsplit_initialiser_bis comma_before = function
390 | [] -> [], [comma_before]
392 let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
393 (x, [comma_before])::xs, lastcomma
398 (*---------------------------------------------------------------------------*)
399 (* coupling: same in type_annotater_c.ml *)
400 let structdef_to_struct_name ty =
402 | qu, (B.StructUnion (su, sopt, fields), iis) ->
404 | Some s , [i1;i2;i3;i4] ->
405 qu, (B.StructUnionName (su, s), [i1;i2])
409 | x -> raise Impossible
411 | _ -> raise Impossible
413 (*---------------------------------------------------------------------------*)
414 let initialisation_to_affectation decl =
416 | B.MacroDecl _ -> F.Decl decl
417 | B.DeclList (xs, iis) ->
419 (* todo?: should not do that if the variable is an array cos
420 * will have x[] = , mais de toute facon ca sera pas un InitExp
423 | [] -> raise Impossible
425 let ((var, returnType, storage, local),iisep) = x in
428 | Some ((s, ini), iis::iini) ->
430 | Some (B.InitExpr e, ii_empty2) ->
433 Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
434 | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
437 ref (Some ((Lib_parsing_c.al_type returnType),local),
439 let id = (B.Ident s, typ),[iis] in
441 ((B.Assignment (id, B.SimpleAssign, e),
442 Ast_c.noType()), iini)
448 pr2_once "TODO: initialisation_to_affectation for multi vars";
449 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
450 * the Sequence expression operator of C and make an
451 * ExprStatement from that.
460 (*****************************************************************************)
461 (* Functor parameter combinators *)
462 (*****************************************************************************)
464 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
466 * version0: was not tagging the SP, so just tag the C
468 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
469 * val return : 'b -> tin -> 'b tout
470 * val fail : tin -> 'b tout
472 * version1: now also tag the SP so return a ('a * 'b)
475 type mode = PatternMode | TransformMode
483 type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
488 (tin -> ('a * 'b) tout) ->
489 ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
490 (tin -> ('c * 'd) tout)
492 val return : ('a * 'b) -> tin -> ('a *'b) tout
493 val fail : tin -> ('a * 'b) tout
505 val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
507 val tokenf : ('a A.mcode, B.info) matcher
508 val tokenf_mck : (A.mcodekind, B.info) matcher
511 (A.meta_name A.mcode, B.expression) matcher
513 (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
515 (A.meta_name A.mcode, Ast_c.fullType) matcher
517 (A.meta_name A.mcode,
518 (Ast_c.parameterType, Ast_c.il) either list) matcher
520 (A.meta_name A.mcode, Ast_c.parameterType) matcher
522 (A.meta_name A.mcode, Ast_c.initialiser) matcher
524 (A.meta_name A.mcode, Control_flow_c.node) matcher
526 val distrf_define_params :
527 (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
530 val distrf_struct_fields :
531 (A.meta_name A.mcode, B.field B.wrap list) matcher
534 (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
537 (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
540 (A.expression, B.expression) matcher ->
541 (A.expression, B.expression) matcher
544 (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
547 A.keep_binding -> A.inherited ->
548 A.meta_name A.mcode * Ast_c.metavar_binding_kind *
549 (unit -> Common.filename * Ast_c.posl * Ast_c.posl) ->
550 (unit -> tin -> 'x tout) -> (tin -> 'x tout)
552 val check_constraints :
553 ('a, 'b) matcher -> 'a list -> 'b ->
554 (unit -> tin -> 'x tout) -> (tin -> 'x tout)
556 val all_bound : A.meta_name list -> (tin -> bool)
558 val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
559 val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
560 val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
565 (*****************************************************************************)
566 (* Functor code, "Cocci vs C" *)
567 (*****************************************************************************)
570 functor (X : PARAM) ->
573 type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
576 let return = X.return
579 let (>||>) = X.(>||>)
580 let (>|+|>) = X.(>|+|>)
581 let (>&&>) = X.(>&&>)
583 let tokenf = X.tokenf
585 (* should be raise Impossible when called from transformation.ml *)
588 | PatternMode -> fail
589 | TransformMode -> raise Impossible
592 let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
594 | (Some t1, Some t2) ->
595 f t1 t2 >>= (fun t1 t2 ->
596 return (Some t1, Some t2)
598 | (None, None) -> return (None, None)
601 (* Dots are sometimes used as metavariables, since like metavariables they
602 can match other things. But they no longer have the same type. Perhaps these
603 functions could be avoided by introducing an appropriate level of polymorphism,
604 but I don't know how to declare polymorphism across functors *)
605 let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
606 let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
608 (*---------------------------------------------------------------------------*)
620 (*---------------------------------------------------------------------------*)
621 let rec (expression: (A.expression, Ast_c.expression) matcher) =
623 X.all_bound (A.get_inherited ea) >&&>
624 let wa x = A.rewrap ea x in
625 match A.unwrap ea, eb with
627 (* general case: a MetaExpr can match everything *)
628 | A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
629 (((expr, opttypb), ii) as expb) ->
631 (* old: before have a MetaConst. Now we factorize and use 'form' to
632 * differentiate between different cases *)
633 let rec matches_id = function
635 | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
638 match (form,expr) with
641 let rec matches = function
642 B.Constant(c) -> true
643 | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
644 pr2_once ("warning: I consider " ^ idb ^ " as a constant");
646 | B.Cast(ty,e) -> matches (B.unwrap_expr e)
647 | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
648 | B.SizeOfExpr(exp) -> true
649 | B.SizeOfType(ty) -> true
655 (Some (_,Ast_c.LocalVar _),_) -> true
657 | (A.ID,e) -> matches_id e in
661 (let (opttypb,_testb) = !opttypb in
662 match opttypa, opttypb with
663 | None, _ -> return ((),())
665 pr2_once ("Missing type information. Certainly a pb in " ^
666 "annotate_typer.ml");
669 | Some tas, Some tb ->
670 tas +> List.fold_left (fun acc ta ->
671 acc >|+|> compatible_type ta tb) fail
674 X.check_constraints expression constraints eb
677 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
678 X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
680 X.distrf_e ida expb >>= (fun ida expb ->
682 A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
690 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
691 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
693 * but bug! because if have not tagged SP, then transform without doing
694 * any checks. Hopefully now have tagged SP technique.
699 * | A.Edots _, _ -> raise Impossible.
701 * In fact now can also have the Edots inside normal expression, not
702 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
704 | A.Edots (mcode, None), expb ->
705 X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
707 A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
712 | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
715 | A.Ident ida, ((B.Ident idb, typ),ii) ->
716 let ib1 = tuple_of_list1 ii in
717 ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
719 ((A.Ident ida)) +> wa,
720 ((B.Ident idb, typ),[ib1])
726 | A.MetaErr _, _ -> failwith "not handling MetaErr"
728 (* todo?: handle some isomorphisms in int/float ? can have different
729 * format : 1l can match a 1.
731 * todo: normally string can contain some metavar too, so should
732 * recurse on the string
734 | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
735 (* for everything except the String case where can have multi elems *)
737 let ib1 = tuple_of_list1 ii in
738 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
740 ((A.Constant ia1)) +> wa,
741 ((B.Constant (ib), typ),[ib1])
744 (match term ia1, ib with
745 | A.Int x, B.Int y ->
746 X.value_format_flag (fun use_value_equivalence ->
747 if use_value_equivalence
757 | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
759 | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
762 | A.String sa, B.String (sb,_kind) when sa =$= sb ->
765 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
767 ((A.Constant ia1)) +> wa,
768 ((B.Constant (ib), typ),[ib1])
770 | _ -> fail (* multi string, not handled *)
776 | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
777 (* todo: do special case to allow IdMetaFunc, cos doing the
778 * recursive call will be too late, match_ident will not have the
779 * info whether it was a function. todo: but how detect when do
780 * x.field = f; how know that f is a Func ? By having computed
781 * some information before the matching!
783 * Allow match with FunCall containing types. Now ast_cocci allow
784 * type in parameter, and morover ast_cocci allow f(...) and those
785 * ... could match type.
787 let (ib1, ib2) = tuple_of_list2 ii in
788 expression ea eb >>= (fun ea eb ->
789 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
790 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
791 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
792 let eas = redots eas easundots in
794 ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
795 ((B.FunCall (eb, ebs),typ), [ib1;ib2])
801 | A.Assignment (ea1, opa, ea2, simple),
802 ((B.Assignment (eb1, opb, eb2), typ),ii) ->
803 let (opbi) = tuple_of_list1 ii in
804 if equal_assignOp (term opa) opb
806 expression ea1 eb1 >>= (fun ea1 eb1 ->
807 expression ea2 eb2 >>= (fun ea2 eb2 ->
808 tokenf opa opbi >>= (fun opa opbi ->
810 ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
811 ((B.Assignment (eb1, opb, eb2), typ), [opbi])
815 | A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
816 let (ib1, ib2) = tuple_of_list2 ii in
817 expression ea1 eb1 >>= (fun ea1 eb1 ->
818 option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
819 expression ea3 eb3 >>= (fun ea3 eb3 ->
820 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
821 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
823 ((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
824 ((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
827 (* todo?: handle some isomorphisms here ? *)
828 | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
829 let opbi = tuple_of_list1 ii in
830 if equal_fixOp (term opa) opb
832 expression ea eb >>= (fun ea eb ->
833 tokenf opa opbi >>= (fun opa opbi ->
835 ((A.Postfix (ea, opa))) +> wa,
836 ((B.Postfix (eb, opb), typ),[opbi])
841 | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
842 let opbi = tuple_of_list1 ii in
843 if equal_fixOp (term opa) opb
845 expression ea eb >>= (fun ea eb ->
846 tokenf opa opbi >>= (fun opa opbi ->
848 ((A.Infix (ea, opa))) +> wa,
849 ((B.Infix (eb, opb), typ),[opbi])
853 | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
854 let opbi = tuple_of_list1 ii in
855 if equal_unaryOp (term opa) opb
857 expression ea eb >>= (fun ea eb ->
858 tokenf opa opbi >>= (fun opa opbi ->
860 ((A.Unary (ea, opa))) +> wa,
861 ((B.Unary (eb, opb), typ),[opbi])
865 | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
866 let opbi = tuple_of_list1 ii in
867 if equal_binaryOp (term opa) opb
869 expression ea1 eb1 >>= (fun ea1 eb1 ->
870 expression ea2 eb2 >>= (fun ea2 eb2 ->
871 tokenf opa opbi >>= (fun opa opbi ->
873 ((A.Binary (ea1, opa, ea2))) +> wa,
874 ((B.Binary (eb1, opb, eb2), typ),[opbi]
878 | A.Nested (ea1, opa, ea2), eb ->
880 (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
881 else expression ea1 eb) >|+|>
883 ((B.Binary (eb1, opb, eb2), typ),ii)
884 when equal_binaryOp (term opa) opb ->
885 let opbi = tuple_of_list1 ii in
887 (expression ea1 eb1 >>= (fun ea1 eb1 ->
888 expression ea2 eb2 >>= (fun ea2 eb2 ->
889 tokenf opa opbi >>= (fun opa opbi ->
891 ((A.Nested (ea1, opa, ea2))) +> wa,
892 ((B.Binary (eb1, opb, eb2), typ),[opbi]
895 (expression ea2 eb1 >>= (fun ea2 eb1 ->
896 expression ea1 eb2 >>= (fun ea1 eb2 ->
897 tokenf opa opbi >>= (fun opa opbi ->
899 ((A.Nested (ea1, opa, ea2))) +> wa,
900 ((B.Binary (eb1, opb, eb2), typ),[opbi]
903 (loop eb1 >>= (fun ea1 eb1 ->
904 expression ea2 eb2 >>= (fun ea2 eb2 ->
905 tokenf opa opbi >>= (fun opa opbi ->
907 ((A.Nested (ea1, opa, ea2))) +> wa,
908 ((B.Binary (eb1, opb, eb2), typ),[opbi]
911 (expression ea2 eb1 >>= (fun ea2 eb1 ->
912 loop eb2 >>= (fun ea1 eb2 ->
913 tokenf opa opbi >>= (fun opa opbi ->
915 ((A.Nested (ea1, opa, ea2))) +> wa,
916 ((B.Binary (eb1, opb, eb2), typ),[opbi]
918 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
922 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
923 | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
924 let (ib1, ib2) = tuple_of_list2 ii in
925 expression ea1 eb1 >>= (fun ea1 eb1 ->
926 expression ea2 eb2 >>= (fun ea2 eb2 ->
927 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
928 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
930 ((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
931 ((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
934 (* todo?: handle some isomorphisms here ? *)
935 | A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
936 let (ib1, ib2) = tuple_of_list2 ii in
937 ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
938 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
939 expression ea eb >>= (fun ea eb ->
941 ((A.RecordAccess (ea, ia1, ida))) +> wa,
942 ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
947 | A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
948 let (ib1, ib2) = tuple_of_list2 ii in
949 ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
950 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
951 expression ea eb >>= (fun ea eb ->
953 ((A.RecordPtAccess (ea, ia1, ida))) +> wa,
954 ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
958 (* todo?: handle some isomorphisms here ?
959 * todo?: do some iso-by-absence on cast ?
960 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
963 | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
964 let (ib1, ib2) = tuple_of_list2 ii in
965 fullType typa typb >>= (fun typa typb ->
966 expression ea eb >>= (fun ea eb ->
967 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
968 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
970 ((A.Cast (ia1, typa, ia2, ea))) +> wa,
971 ((B.Cast (typb, eb),typ),[ib1;ib2])
974 | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
975 let ib1 = tuple_of_list1 ii in
976 expression ea eb >>= (fun ea eb ->
977 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
979 ((A.SizeOfExpr (ia1, ea))) +> wa,
980 ((B.SizeOfExpr (eb), typ),[ib1])
983 | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
984 let (ib1,ib2,ib3) = tuple_of_list3 ii in
985 fullType typa typb >>= (fun typa typb ->
986 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
987 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
988 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
990 ((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
991 ((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
995 (* todo? iso ? allow all the combinations ? *)
996 | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
997 let (ib1, ib2) = tuple_of_list2 ii in
998 expression ea eb >>= (fun ea eb ->
999 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1000 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1002 ((A.Paren (ia1, ea, ia2))) +> wa,
1003 ((B.ParenExpr (eb), typ), [ib1;ib2])
1006 | A.NestExpr(exps,None,true), eb ->
1007 (match A.unwrap exps with
1009 X.cocciExpExp expression exp eb >>= (fun exp eb ->
1011 (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
1017 "for nestexpr, only handling the case with dots and only one exp")
1019 | A.NestExpr _, _ ->
1020 failwith "only handling multi and no when code in a nest expr"
1022 (* only in arg lists or in define body *)
1023 | A.TypeExp _, _ -> fail
1025 (* only in arg lists *)
1026 | A.MetaExprList _, _
1033 | A.DisjExpr eas, eb ->
1034 eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
1036 | A.UniqueExp _,_ | A.OptExp _,_ ->
1037 failwith "not handling Opt/Unique/Multi on expr"
1039 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1041 (* have not a counter part in coccinelle, for the moment *)
1042 | _, ((B.Sequence _,_),_)
1043 | _, ((B.StatementExpr _,_),_)
1044 | _, ((B.Constructor _,_),_)
1051 (* ------------------------------------------------------------------------- *)
1052 and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
1053 fun infoidb ida ((idb, iib) as ib) ->
1054 X.all_bound (A.get_inherited ida) >&&>
1055 match A.unwrap ida with
1057 if (term sa) =$= idb then
1058 tokenf sa iib >>= (fun sa iib ->
1060 ((A.Id sa)) +> A.rewrap ida,
1066 | A.MetaId(mida,constraints,keep,inherited) ->
1067 X.check_constraints (ident infoidb) constraints ib
1069 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1070 (* use drop_pos for ids so that the pos is not added a second time in
1071 the call to tokenf *)
1072 X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
1074 tokenf mida iib >>= (fun mida iib ->
1076 ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
1081 | A.MetaFunc(mida,constraints,keep,inherited) ->
1083 X.check_constraints (ident infoidb) constraints ib
1085 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1086 X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
1088 tokenf mida iib >>= (fun mida iib ->
1090 ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
1095 | LocalFunction | Function -> is_function()
1097 failwith "MetaFunc, need more semantic info about id"
1098 (* the following implementation could possibly be useful, if one
1099 follows the convention that a macro is always in capital letters
1100 and that a macro is not a function.
1101 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1104 | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
1107 X.check_constraints (ident infoidb) constraints ib
1109 let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
1110 X.envf keep inherited
1111 (A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
1113 tokenf mida iib >>= (fun mida iib ->
1115 ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
1121 | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
1124 | A.OptIdent _ | A.UniqueIdent _ ->
1125 failwith "not handling Opt/Unique for ident"
1129 (* ------------------------------------------------------------------------- *)
1130 and (arguments: sequence ->
1131 (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
1132 fun seqstyle eas ebs ->
1134 | Unordered -> failwith "not handling ooo"
1136 arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
1137 return (eas, (Ast_c.unsplit_comma ebs_splitted))
1139 (* because '...' can match nothing, need to take care when have
1140 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1141 * f(1,2) for instance.
1142 * So I have added special cases such as (if startxs = []) and code
1143 * in the Ecomma matching rule.
1145 * old: Must do some try, for instance when f(...,X,Y,...) have to
1146 * test the transfo for all the combinaitions and if multiple transfo
1147 * possible ? pb ? => the type is to return a expression option ? use
1148 * some combinators to help ?
1149 * update: with the tag-SP approach, no more a problem.
1152 and arguments_bis = fun eas ebs ->
1154 | [], [] -> return ([], [])
1155 | [], eb::ebs -> fail
1157 X.all_bound (A.get_inherited ea) >&&>
1158 (match A.unwrap ea, ebs with
1159 | A.Edots (mcode, optexpr), ys ->
1160 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1161 if optexpr <> None then failwith "not handling when in argument";
1163 (* '...' can take more or less the beginnings of the arguments *)
1164 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1165 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1168 (* allow '...', and maybe its associated ',' to match nothing.
1169 * for the associated ',' see below how we handle the EComma
1174 if mcode_contain_plus (mcodekind mcode)
1176 (* failwith "I have no token that I could accroche myself on" *)
1177 else return (dots2metavar mcode, [])
1179 (* subtil: we dont want the '...' to match until the
1180 * comma. cf -test pb_params_iso. We would get at
1181 * "already tagged" error.
1182 * this is because both f (... x, ...) and f (..., x, ...)
1183 * would match a f(x,3) with our "optional-comma" strategy.
1185 (match Common.last startxs with
1188 X.distrf_args (dots2metavar mcode) startxs
1191 >>= (fun mcode startxs ->
1192 let mcode = metavar2dots mcode in
1193 arguments_bis eas endxs >>= (fun eas endxs ->
1195 (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
1201 | A.EComma ia1, Right ii::ebs ->
1202 let ib1 = tuple_of_list1 ii in
1203 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1204 arguments_bis eas ebs >>= (fun eas ebs ->
1206 (A.EComma ia1 +> A.rewrap ea)::eas,
1210 | A.EComma ia1, ebs ->
1211 (* allow ',' to maching nothing. optional comma trick *)
1212 if mcode_contain_plus (mcodekind ia1)
1214 else arguments_bis eas ebs
1216 | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
1217 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1218 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1223 if mcode_contain_plus (mcodekind ida)
1225 (* failwith "no token that I could accroche myself on" *)
1228 (match Common.last startxs with
1236 let startxs' = Ast_c.unsplit_comma startxs in
1237 let len = List.length startxs' in
1240 | Some (lenname,lenkeep,leninherited) ->
1241 let max_min _ = failwith "no pos" in
1242 X.envf lenkeep leninherited
1243 (lenname, Ast_c.MetaListlenVal (len), max_min)
1244 | None -> function f -> f()
1248 Lib_parsing_c.lin_col_by_pos
1249 (Lib_parsing_c.ii_of_args startxs) in
1250 X.envf keep inherited
1251 (ida, Ast_c.MetaExprListVal startxs', max_min)
1254 then return (ida, [])
1255 else X.distrf_args ida (Ast_c.split_comma startxs')
1257 >>= (fun ida startxs ->
1258 arguments_bis eas endxs >>= (fun eas endxs ->
1260 (A.MetaExprList(ida,leninfo,keep,inherited))
1261 +> A.rewrap ea::eas,
1269 | _unwrapx, (Left eb)::ebs ->
1270 argument ea eb >>= (fun ea eb ->
1271 arguments_bis eas ebs >>= (fun eas ebs ->
1272 return (ea::eas, Left eb::ebs)
1274 | _unwrapx, (Right y)::ys -> raise Impossible
1275 | _unwrapx, [] -> fail
1279 and argument arga argb =
1280 X.all_bound (A.get_inherited arga) >&&>
1281 match A.unwrap arga, argb with
1282 | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
1284 if b || sopt <> None
1286 (* failwith "the argument have a storage and ast_cocci does not have"*)
1289 fullType tya tyb >>= (fun tya tyb ->
1291 (A.TypeExp tya) +> A.rewrap arga,
1292 (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
1295 | A.TypeExp tya, _ -> fail
1296 | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
1298 expression arga argb >>= (fun arga argb ->
1299 return (arga, Left argb)
1301 | _, Right (B.ArgAction y) -> fail
1304 (* ------------------------------------------------------------------------- *)
1305 (* todo? facto code with argument ? *)
1306 and (parameters: sequence ->
1307 (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
1309 fun seqstyle eas ebs ->
1311 | Unordered -> failwith "not handling ooo"
1313 parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
1314 return (eas, (Ast_c.unsplit_comma ebs_splitted))
1318 and parameters_bis eas ebs =
1320 | [], [] -> return ([], [])
1321 | [], eb::ebs -> fail
1323 (* the management of positions is inlined into each case, because
1324 sometimes there is a Param and sometimes a ParamList *)
1325 X.all_bound (A.get_inherited ea) >&&>
1326 (match A.unwrap ea, ebs with
1327 | A.Pdots (mcode), ys ->
1329 (* '...' can take more or less the beginnings of the arguments *)
1330 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1331 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1336 if mcode_contain_plus (mcodekind mcode)
1338 (* failwith "I have no token that I could accroche myself on"*)
1339 else return (dots2metavar mcode, [])
1341 (match Common.last startxs with
1344 X.distrf_params (dots2metavar mcode) startxs
1346 ) >>= (fun mcode startxs ->
1347 let mcode = metavar2dots mcode in
1348 parameters_bis eas endxs >>= (fun eas endxs ->
1350 (A.Pdots (mcode) +> A.rewrap ea) ::eas,
1356 | A.PComma ia1, Right ii::ebs ->
1357 let ib1 = tuple_of_list1 ii in
1358 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1359 parameters_bis eas ebs >>= (fun eas ebs ->
1361 (A.PComma ia1 +> A.rewrap ea)::eas,
1366 | A.PComma ia1, ebs ->
1367 (* try optional comma trick *)
1368 if mcode_contain_plus (mcodekind ia1)
1370 else parameters_bis eas ebs
1373 | A.MetaParamList(ida,leninfo,keep,inherited),ys->
1374 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
1375 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
1380 if mcode_contain_plus (mcodekind ida)
1382 (* failwith "I have no token that I could accroche myself on" *)
1385 (match Common.last startxs with
1393 let startxs' = Ast_c.unsplit_comma startxs in
1394 let len = List.length startxs' in
1397 Some (lenname,lenkeep,leninherited) ->
1398 let max_min _ = failwith "no pos" in
1399 X.envf lenkeep leninherited
1400 (lenname, Ast_c.MetaListlenVal (len), max_min)
1401 | None -> function f -> f()
1405 Lib_parsing_c.lin_col_by_pos
1406 (Lib_parsing_c.ii_of_params startxs) in
1407 X.envf keep inherited
1408 (ida, Ast_c.MetaParamListVal startxs', max_min)
1411 then return (ida, [])
1412 else X.distrf_params ida (Ast_c.split_comma startxs')
1413 ) >>= (fun ida startxs ->
1414 parameters_bis eas endxs >>= (fun eas endxs ->
1416 (A.MetaParamList(ida,leninfo,keep,inherited))
1417 +> A.rewrap ea::eas,
1425 | A.VoidParam ta, ys ->
1426 (match eas, ebs with
1428 let ((hasreg, idbopt, tb), ii_b_s) = eb in
1429 if idbopt = None && null ii_b_s
1432 | (qub, (B.BaseType B.Void,_)) ->
1433 fullType ta tb >>= (fun ta tb ->
1435 [(A.VoidParam ta) +> A.rewrap ea],
1436 [Left ((hasreg, idbopt, tb), ii_b_s)]
1443 | (A.OptParam _ | A.UniqueParam _), _ ->
1444 failwith "handling Opt/Unique for Param"
1446 | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
1449 | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
1450 (* todo: use quaopt, hasreg ? *)
1452 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
1453 X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
1454 X.distrf_param ida eb
1455 ) >>= (fun ida eb ->
1456 parameters_bis eas ebs >>= (fun eas ebs ->
1458 (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
1463 | A.Param (typa, idaopt), (Left eb)::ebs ->
1464 (*this should succeed if the C code has a name, and fail otherwise*)
1465 parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
1466 parameters_bis eas ebs >>= (fun eas ebs ->
1468 (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
1472 | _unwrapx, (Right y)::ys -> raise Impossible
1473 | _unwrapx, [] -> fail
1480 and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
1481 fullType typa typb >>= (fun typa typb ->
1482 match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
1483 | Some ida, Left (idb, iihasreg, iidb) ->
1484 (* todo: if minus on ida, should also minus the iihasreg ? *)
1485 ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
1488 ((hasreg, Some idb, typb), iihasreg++[iidb])
1491 | None, Right iihasreg ->
1494 ((hasreg, None, typb), iihasreg)
1498 (* why handle this case ? because of transform_proto ? we may not
1499 * have an ident in the proto.
1500 * If have some plus on ida ? do nothing about ida ?
1502 (* not anymore !!! now that julia is handling the proto.
1503 | _, Right iihasreg ->
1506 ((hasreg, None, typb), iihasreg)
1510 | Some _, Right _ -> fail
1511 | None, Left _ -> fail
1517 (* ------------------------------------------------------------------------- *)
1518 and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
1519 fun (mckstart, allminus, decla) declb ->
1520 X.all_bound (A.get_inherited decla) >&&>
1521 match A.unwrap decla, declb with
1523 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1524 * de toutes les declarations qui sont au debut d'un fonction et
1525 * commencer le reste du match au premier statement. Alors, ca matche
1526 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1527 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1529 * When the SP want to remove the whole function, the minus is not
1530 * on the MetaDecl but on the MetaRuleElem. So there should
1531 * be no transform of MetaDecl, just matching are allowed.
1534 | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
1535 (* todo: should not happen in transform mode *)
1536 return ((mckstart, allminus, decla), declb)
1540 | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
1541 onedecl allminus decla (var,iiptvirgb,iisto) >>=
1542 (fun decla (var,iiptvirgb,iisto)->
1543 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1545 (mckstart, allminus, decla),
1546 (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
1549 | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
1550 if X.mode = PatternMode
1552 xs +> List.fold_left (fun acc var ->
1554 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1555 onedecl allminus decla (var, iiptvirgb, iisto) >>=
1556 (fun decla (var, iiptvirgb, iisto) ->
1558 (mckstart, allminus, decla),
1559 (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
1563 failwith "More that one variable in decl. Have to split to transform."
1565 | A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
1566 let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
1568 | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
1569 (iisb,lpb,rpb,iiendb, iifakestart,iisto)
1570 | _ -> raise Impossible
1573 then minusize_list iistob
1574 else return ((), iistob)
1575 ) >>= (fun () iistob ->
1577 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
1578 ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
1579 tokenf lpa lpb >>= (fun lpa lpb ->
1580 tokenf rpa rpb >>= (fun rpa rpb ->
1581 tokenf enda iiendb >>= (fun enda iiendb ->
1582 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
1583 let eas = redots eas easundots in
1586 (mckstart, allminus,
1587 (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
1588 (B.MacroDecl ((sb,ebs),
1589 [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
1596 and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
1597 X.all_bound (A.get_inherited decla) >&&>
1598 match A.unwrap decla, declb with
1600 (* kind of typedef iso, we must unfold, it's for the case
1601 * T { }; that we want to match against typedef struct { } xx_t;
1603 | A.TyDecl (tya0, ptvirga),
1604 ((Some ((idb, None),[iidb]), typb0, (B.StoTypedef, inl), local), iivirg) ->
1606 (match A.unwrap tya0, typb0 with
1607 | A.Type(cv1,tya1), ((qu,il),typb1) ->
1609 (match A.unwrap tya1, typb1 with
1610 | A.StructUnionDef(tya2, lba, declsa, rba),
1611 (B.StructUnion (sub, sbopt, declsb), ii) ->
1613 let (iisub, iisbopt, lbb, rbb) =
1616 let (iisub, lbb, rbb) = tuple_of_list3 ii in
1617 (iisub, [], lbb, rbb)
1620 "warning: both a typedef (%s) and struct name introduction (%s)"
1623 pr2 "warning: I will consider only the typedef";
1624 let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
1625 (iisub, [iisb], lbb, rbb)
1628 structdef_to_struct_name
1629 (Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
1632 Ast_c.nQ,((B.TypeName (idb, Some
1633 (Lib_parsing_c.al_type structnameb))), [iidb])
1636 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1637 tokenf lba lbb >>= (fun lba lbb ->
1638 tokenf rba rbb >>= (fun rba rbb ->
1639 struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
1640 let declsa = redots declsa undeclsa in
1642 (match A.unwrap tya2 with
1643 | A.Type(cv3, tya3) ->
1644 (match A.unwrap tya3 with
1645 | A.MetaType(ida,keep, inherited) ->
1647 fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
1649 A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
1650 let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
1653 let typb1 = B.StructUnion (sub,sbopt, declsb),
1654 [iisub] @ iisbopt @ [lbb;rbb] in
1655 let typb0 = ((qu, il), typb1) in
1657 match fake_typeb with
1658 | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
1661 (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
1662 (((Some ((idb, None),[iidb]), typb0, (B.StoTypedef, inl),
1664 iivirg),iiptvirgb,iistob)
1666 | _ -> raise Impossible
1669 | A.StructUnionName(sua, sa) ->
1671 fullType tya2 structnameb >>= (fun tya2 structnameb ->
1673 let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
1675 let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
1677 match structnameb with
1678 | _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
1680 let typb1 = B.StructUnion (sub,sbopt, declsb),
1681 [iisub;iisbopt;lbb;rbb] in
1682 let typb0 = ((qu, il), typb1) in
1685 (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
1686 (((Some ((idb, None),[iidb]), typb0,
1687 (B.StoTypedef, inl), local),
1688 iivirg),iiptvirgb,iistob)
1690 | _ -> raise Impossible
1692 | _ -> raise Impossible
1701 | A.UnInit (stoa, typa, ida, ptvirga),
1702 ((Some ((idb, _),[iidb]), typb, (B.StoTypedef,_), _local), iivirg) ->
1705 | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
1706 ((Some ((idb, _),[iidb]), typb, (B.StoTypedef,_), _local), iivirg) ->
1711 (* could handle iso here but handled in standard.iso *)
1712 | A.UnInit (stoa, typa, ida, ptvirga),
1713 ((Some ((idb, None),[iidb]), typb, stob, local), iivirg) ->
1714 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1715 fullType typa typb >>= (fun typa typb ->
1716 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1717 storage_optional_allminus allminus stoa (stob, iistob) >>=
1718 (fun stoa (stob, iistob) ->
1720 (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
1721 (((Some ((idb,None),[iidb]),typb,stob,local),iivirg),
1725 | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
1726 ((Some((idb,Some inib),[iidb;iieqb]),typb,stob,local),iivirg)
1728 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1729 tokenf eqa iieqb >>= (fun eqa iieqb ->
1730 fullType typa typb >>= (fun typa typb ->
1731 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1732 storage_optional_allminus allminus stoa (stob, iistob) >>=
1733 (fun stoa (stob, iistob) ->
1734 initialiser inia inib >>= (fun inia inib ->
1736 (A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
1737 (((Some((idb,Some inib),[iidb;iieqb]),typb,stob,local),iivirg),
1741 (* do iso-by-absence here ? allow typedecl and var ? *)
1742 | A.TyDecl (typa, ptvirga), ((None, typb, stob, local), iivirg) ->
1743 if stob = (B.NoSto, false)
1745 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1746 fullType typa typb >>= (fun typa typb ->
1748 (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
1749 (((None, typb, stob, local), iivirg), iiptvirgb, iistob)
1754 | A.Typedef (stoa, typa, ida, ptvirga),
1755 ((Some ((idb, None),[iidb]),typb,(B.StoTypedef,inline),local),iivirg) ->
1757 tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
1758 fullType typa typb >>= (fun typa typb ->
1761 tokenf stoa iitypedef >>= (fun stoa iitypedef ->
1762 return (stoa, [iitypedef])
1764 | _ -> failwith "wierd, have both typedef and inline or nothing";
1765 ) >>= (fun stoa iistob ->
1766 (match A.unwrap ida with
1767 | A.MetaType(_,_,_) ->
1770 Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
1772 fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
1773 match fake_typeb with
1774 | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
1775 return (ida, (idb, iidb))
1776 | _ -> raise Impossible
1780 if (term sa) =$= idb
1782 tokenf sa iidb >>= (fun sa iidb ->
1784 (A.TypeName sa) +> A.rewrap ida,
1788 | _ -> raise Impossible
1790 ) >>= (fun ida (idb, iidb) ->
1792 (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
1793 (((Some ((idb, None),[iidb]), typb, (B.StoTypedef,inline),local),
1800 | _, ((None, typb, sto, _local), _) ->
1801 (* old: failwith "no variable in this declaration, wierd" *)
1806 | A.DisjDecl declas, declb ->
1807 declas +> List.fold_left (fun acc decla ->
1809 (* (declaration (mckstart, allminus, decla) declb) *)
1810 (onedecl allminus decla (declb,iiptvirgb, iistob))
1815 (* only in struct type decls *)
1816 | A.Ddots(dots,whencode), _ ->
1819 | A.OptDecl _, _ | A.UniqueDecl _, _ ->
1820 failwith "not handling Opt/Unique Decl"
1827 (* ------------------------------------------------------------------------- *)
1829 and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
1830 X.all_bound (A.get_inherited ia) >&&>
1831 match (A.unwrap ia,ib) with
1833 | (A.InitExpr expa, ib) ->
1834 (match A.unwrap expa, ib with
1835 | A.Edots (mcode, None), ib ->
1836 X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
1839 (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
1844 | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
1846 | _, (B.InitExpr expb, ii) ->
1848 expression expa expb >>= (fun expa expb ->
1850 (A.InitExpr expa) +> A.rewrap ia,
1851 (B.InitExpr expb, ii)
1856 | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
1858 | ib1::ib2::iicommaopt ->
1859 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1860 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1861 initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
1863 (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
1864 (B.InitList ibs, ib1::ib2::iicommaopt)
1867 | _ -> raise Impossible
1870 | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
1871 failwith "TODO: not handling whencode in initialisers"
1874 | (A.InitGccDotName (ia1, ida, ia2, inia),
1875 (B.InitDesignators ([B.DesignatorField idb,ii1], inib), ii2))->
1877 let (iidot, iidb) = tuple_of_list2 ii1 in
1878 let iieq = tuple_of_list1 ii2 in
1880 tokenf ia1 iidot >>= (fun ia1 iidot ->
1881 tokenf ia2 iieq >>= (fun ia2 iieq ->
1882 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1883 initialiser inia inib >>= (fun inia inib ->
1885 (A.InitGccDotName (ia1, ida, ia2, inia)) +> A.rewrap ia,
1887 ([B.DesignatorField idb, [iidot;iidb]], inib), [iieq])
1891 | (A.InitGccIndex (ia1,ea,ia2,ia3,inia),
1892 (B.InitDesignators ([B.DesignatorIndex eb, ii1], inib), ii2)) ->
1894 let (ib1, ib2) = tuple_of_list2 ii1 in
1895 let ib3 = tuple_of_list1 ii2 in
1896 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1897 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1898 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
1899 expression ea eb >>= (fun ea eb ->
1900 initialiser inia inib >>= (fun inia inib ->
1902 (A.InitGccIndex (ia1,ea,ia2,ia3,inia)) +> A.rewrap ia,
1904 ([B.DesignatorIndex eb, [ib1;ib2]], inib), [ib3])
1908 | (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia),
1909 (B.InitDesignators ([B.DesignatorRange (e1b, e2b), ii1], inib), ii2)) ->
1911 let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
1912 let (ib4) = tuple_of_list1 ii2 in
1913 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
1914 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
1915 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
1916 tokenf ia4 ib4 >>= (fun ia4 ib4 ->
1917 expression e1a e1b >>= (fun e1a e1b ->
1918 expression e2a e2b >>= (fun e2a e2b ->
1919 initialiser inia inib >>= (fun inia inib ->
1921 (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia)) +> A.rewrap ia,
1923 ([B.DesignatorRange (e1b, e2b),[ib1;ib2;ib3]], inib), [ib4])
1929 | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
1932 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
1933 initialiser inia inib >>= (fun inia inib ->
1934 tokenf ia1 iicolon >>= (fun ia1 iicolon ->
1936 (A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
1937 (B.InitFieldOld (idb, inib), [iidb;iicolon])
1944 | A.IComma(comma), _ ->
1947 | A.UniqueIni _,_ | A.OptIni _,_ ->
1948 failwith "not handling Opt/Unique on initialisers"
1956 and initialisers = fun ias (ibs, iicomma) ->
1957 let ias_unsplit = unsplit_icomma ias in
1958 let ibs_split = resplit_initialiser ibs iicomma in
1961 if need_unordered_initialisers ibs
1962 then initialisers_unordered2
1963 else initialisers_ordered2
1965 f ias_unsplit ibs_split >>=
1966 (fun ias_unsplit ibs_split ->
1968 split_icomma ias_unsplit,
1969 unsplit_initialiser ibs_split
1973 (* todo: one day julia will reput a IDots *)
1974 and initialisers_ordered2 = fun ias ibs ->
1976 | [], [] -> return ([], [])
1977 | (x, xcomma)::xs, (y, commay)::ys ->
1978 (match A.unwrap xcomma with
1979 | A.IComma commax ->
1980 tokenf commax commay >>= (fun commax commay ->
1981 initialiser x y >>= (fun x y ->
1982 initialisers_ordered2 xs ys >>= (fun xs ys ->
1984 (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
1988 | _ -> raise Impossible (* unsplit_iicomma wrong *)
1994 and initialisers_unordered2 = fun ias ibs ->
1997 | [], ys -> return ([], ys)
1998 | (x,xcomma)::xs, ys ->
2000 let permut = Common.uncons_permut_lazy ys in
2001 permut +> List.fold_left (fun acc ((e, pos), rest) ->
2004 (match A.unwrap xcomma, e with
2005 | A.IComma commax, (y, commay) ->
2006 tokenf commax commay >>= (fun commax commay ->
2007 initialiser x y >>= (fun x y ->
2009 (x, (A.IComma commax) +> A.rewrap xcomma),
2013 | _ -> raise Impossible (* unsplit_iicomma wrong *)
2016 let rest = Lazy.force rest in
2017 initialisers_unordered2 xs rest >>= (fun xs rest ->
2020 Common.insert_elem_pos (e, pos) rest
2025 (* ------------------------------------------------------------------------- *)
2026 and (struct_fields: (A.declaration list, B.field B.wrap list) matcher) =
2029 | [], [] -> return ([], [])
2030 | [], eb::ebs -> fail
2032 X.all_bound (A.get_inherited ea) >&&>
2033 (match A.unwrap ea, ebs with
2034 | A.Ddots (mcode, optwhen), ys ->
2035 if optwhen <> None then failwith "not handling when in argument";
2037 (* '...' can take more or less the beginnings of the arguments *)
2038 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
2039 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
2044 if mcode_contain_plus (mcodekind mcode)
2046 (* failwith "I have no token that I could accroche myself on" *)
2047 else return (dots2metavar mcode, [])
2050 X.distrf_struct_fields (dots2metavar mcode) startxs
2051 ) >>= (fun mcode startxs ->
2052 let mcode = metavar2dots mcode in
2053 struct_fields eas endxs >>= (fun eas endxs ->
2055 (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
2060 | _unwrapx, eb::ebs ->
2061 struct_field ea eb >>= (fun ea eb ->
2062 struct_fields eas ebs >>= (fun eas ebs ->
2063 return (ea::eas, eb::ebs)
2066 | _unwrapx, [] -> fail
2069 and (struct_field: (A.declaration, B.field B.wrap) matcher) = fun fa fb ->
2070 let (xfield, ii) = fb in
2071 let iiptvirgb = tuple_of_list1 ii in
2074 | B.FieldDeclList onefield_multivars ->
2076 (match onefield_multivars with
2077 | [] -> raise Impossible
2078 | [onevar,iivirg] ->
2079 assert (null iivirg);
2081 | B.BitField (sopt, typb, expr), ii ->
2082 pr2_once "warning: bitfield not handled by ast_cocci";
2084 | B.Simple (None, typb), ii ->
2085 pr2_once "warning: unamed struct field not handled by ast_cocci";
2087 | B.Simple (Some idb, typb), ii ->
2088 let (iidb) = tuple_of_list1 ii in
2090 (* build a declaration from a struct field *)
2091 let allminus = false in
2093 let stob = B.NoSto, false in
2095 ((Some ((idb, None),[iidb]), typb, stob, Ast_c.NotLocalDecl),
2098 onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
2099 (fun fa (var,iiptvirgb,iisto) ->
2102 | ((Some ((idb, None),[iidb]), typb, stob, local), iivirg) ->
2103 let onevar = B.Simple (Some idb, typb), [iidb] in
2107 (B.FieldDeclList [onevar, iivirg], [iiptvirgb])
2109 | _ -> raise Impossible
2114 pr2_once "PB: More that one variable in decl. Have to split";
2117 | B.EmptyField -> fail
2121 (* ------------------------------------------------------------------------- *)
2122 and (fullType: (A.fullType, Ast_c.fullType) matcher) =
2124 X.optional_qualifier_flag (fun optional_qualifier ->
2125 X.all_bound (A.get_inherited typa) >&&>
2126 match A.unwrap typa, typb with
2127 | A.Type(cv,ty1), ((qu,il),ty2) ->
2129 if qu.B.const && qu.B.volatile
2132 ("warning: the type is both const & volatile but cocci " ^
2133 "does not handle that");
2135 (* Drop out the const/volatile part that has been matched.
2136 * This is because a SP can contain const T v; in which case
2137 * later in match_t_t when we encounter a T, we must not add in
2138 * the environment the whole type.
2143 (* "iso-by-absence" *)
2146 fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
2148 (A.Type(None, ty1)) +> A.rewrap typa,
2152 (match optional_qualifier, qu.B.const || qu.B.volatile with
2153 | false, false -> do_stuff ()
2154 | false, true -> fail
2155 | true, false -> do_stuff ()
2158 then pr2_once "USING optional_qualifier builtin isomorphism";
2164 (* todo: can be __const__ ? can be const & volatile so
2165 * should filter instead ?
2167 (match term x, il with
2168 | A.Const, [i1] when qu.B.const ->
2170 tokenf x i1 >>= (fun x i1 ->
2171 fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
2173 (A.Type(Some x, ty1)) +> A.rewrap typa,
2177 | A.Volatile, [i1] when qu.B.volatile ->
2178 tokenf x i1 >>= (fun x i1 ->
2179 fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
2181 (A.Type(Some x, ty1)) +> A.rewrap typa,
2189 | A.DisjType typas, typb ->
2191 List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
2193 | A.OptType(_), _ | A.UniqueType(_), _
2194 -> failwith "not handling Opt/Unique on type"
2199 * Why not (A.typeC, Ast_c.typeC) matcher ?
2200 * because when there is MetaType, we want that T record the whole type,
2201 * including the qualifier, and so this type (and the new_il function in
2202 * preceding function).
2205 and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
2207 X.all_bound (A.get_inherited ta) >&&>
2208 match A.unwrap ta, tb with
2211 | A.MetaType(ida,keep, inherited), typb ->
2213 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
2214 X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
2215 X.distrf_type ida typb >>= (fun ida typb ->
2217 A.MetaType(ida,keep, inherited) +> A.rewrap ta,
2221 | unwrap, (qub, typb) ->
2222 typeC ta typb >>= (fun ta typb ->
2223 return (ta, (qub, typb))
2227 and (typeC: (A.typeC, Ast_c.typeC) matcher) =
2229 match A.unwrap ta, tb with
2230 | A.BaseType (basea, signaopt), (B.BaseType baseb, ii) ->
2231 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2232 * And even if in baseb we have a Signed Int, that does not mean
2233 * that ii is of length 2, cos Signed is the default, so if in signa
2234 * we have Signed explicitely ? we cant "accrocher" this mcode to
2235 * something :( So for the moment when there is signed in cocci,
2236 * we force that there is a signed in c too (done in pattern.ml).
2238 let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
2241 (* handle some iso on type ? (cf complex C rule for possible implicit
2243 (match term basea, baseb with
2244 | A.VoidType, B.Void
2245 | A.FloatType, B.FloatType (B.CFloat)
2246 | A.DoubleType, B.FloatType (B.CDouble) ->
2247 assert (signaopt = None);
2248 let (ibaseb) = tuple_of_list1 ii in
2249 tokenf basea ibaseb >>= (fun basea ibaseb ->
2251 (A.BaseType (basea, signaopt)) +> A.rewrap ta,
2252 (B.BaseType baseb, [ibaseb])
2255 | A.CharType, B.IntType B.CChar when signaopt = None ->
2256 let ibaseb = tuple_of_list1 ii in
2257 tokenf basea ibaseb >>= (fun basea ibaseb ->
2259 (A.BaseType (basea, signaopt)) +> A.rewrap ta,
2260 (B.BaseType (B.IntType B.CChar), [ibaseb])
2263 | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
2264 let ibaseb = tuple_of_list1 iibaseb in
2265 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2266 tokenf basea ibaseb >>= (fun basea ibaseb ->
2268 (A.BaseType (basea, signaopt)) +> A.rewrap ta,
2269 (B.BaseType (baseb), iisignbopt ++ [ibaseb])
2272 | A.ShortType, B.IntType (B.Si (_, B.CShort))
2273 | A.IntType, B.IntType (B.Si (_, B.CInt))
2274 | A.LongType, B.IntType (B.Si (_, B.CLong)) ->
2277 (* iso-by-presence ? *)
2278 (* when unsigned int in SP, allow have just unsigned in C ? *)
2279 if mcode_contain_plus (mcodekind basea)
2283 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2285 (A.BaseType (basea, signaopt)) +> A.rewrap ta,
2286 (B.BaseType (baseb), iisignbopt ++ [])
2292 "warning: long int or short int not handled by ast_cocci";
2296 sign signaopt signbopt >>= (fun signaopt iisignbopt ->
2297 tokenf basea ibaseb >>= (fun basea ibaseb ->
2299 (A.BaseType (basea, signaopt)) +> A.rewrap ta,
2300 (B.BaseType (baseb), iisignbopt ++ [ibaseb])
2302 | _ -> raise Impossible
2307 | _, B.IntType (B.Si (_, B.CLongLong))
2308 | _, B.FloatType B.CLongDouble
2311 "warning: long long or long double not handled by ast_cocci";
2320 | A.ImplicitInt (signa), (B.BaseType baseb, ii) ->
2321 let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
2322 (match iibaseb, baseb with
2323 | [], B.IntType (B.Si (_sign, B.CInt)) ->
2324 sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
2326 | None -> raise Impossible
2329 (A.ImplicitInt (signa)) +> A.rewrap ta,
2330 (B.BaseType baseb, iisignbopt)
2338 (* todo? iso with array *)
2339 | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
2340 let (ibmult) = tuple_of_list1 ii in
2341 fullType typa typb >>= (fun typa typb ->
2342 tokenf iamult ibmult >>= (fun iamult ibmult ->
2344 (A.Pointer (typa, iamult)) +> A.rewrap ta,
2345 (B.Pointer typb, [ibmult])
2348 | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
2349 (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
2351 let (lpb, rpb) = tuple_of_list2 ii in
2355 ("Not handling well variable length arguments func. "^
2356 "You have been warned");
2357 tokenf lpa lpb >>= (fun lpa lpb ->
2358 tokenf rpa rpb >>= (fun rpa rpb ->
2359 fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
2360 parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
2361 (fun paramsaundots paramsb ->
2362 let paramsa = redots paramsa paramsaundots in
2364 (A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
2365 (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
2373 | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
2374 (B.ParenType t1, ii) ->
2375 let (lp1b, rp1b) = tuple_of_list2 ii in
2376 let (qu1b, t1b) = t1 in
2378 | B.Pointer t2, ii ->
2379 let (starb) = tuple_of_list1 ii in
2380 let (qu2b, t2b) = t2 in
2382 | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
2383 let (lp2b, rp2b) = tuple_of_list2 ii in
2388 ("Not handling well variable length arguments func. "^
2389 "You have been warned");
2391 fullType tya tyb >>= (fun tya tyb ->
2392 tokenf lp1a lp1b >>= (fun lp1a lp1b ->
2393 tokenf rp1a rp1b >>= (fun rp1a rp1b ->
2394 tokenf lp2a lp2b >>= (fun lp2a lp2b ->
2395 tokenf rp2a rp2b >>= (fun rp2a rp2b ->
2396 tokenf stara starb >>= (fun stara starb ->
2397 parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
2398 (fun paramsaundots paramsb ->
2399 let paramsa = redots paramsa paramsaundots in
2403 (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
2408 (B.Pointer t2, [starb]))
2412 (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
2414 (B.ParenType t1, [lp1b;rp1b])
2427 (* todo: handle the iso on optionnal size specifification ? *)
2428 | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
2429 let (ib1, ib2) = tuple_of_list2 ii in
2430 fullType typa typb >>= (fun typa typb ->
2431 option expression eaopt ebopt >>= (fun eaopt ebopt ->
2432 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
2433 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
2435 (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
2436 (B.Array (ebopt, typb), [ib1;ib2])
2440 (* todo: could also match a Struct that has provided a name *)
2441 (* This is for the case where the SmPL code contains "struct x", without
2442 a definition. In this case, the name field is always present.
2443 This case is also called from the case for A.StructUnionDef when
2444 a name is present in the C code. *)
2445 | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
2446 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2447 let (ib1, ib2) = tuple_of_list2 ii in
2448 if equal_structUnion (term sua) sub
2450 ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
2451 tokenf sua ib1 >>= (fun sua ib1 ->
2453 (A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
2454 (B.StructUnionName (sub, sb), [ib1;ib2])
2459 | A.StructUnionDef(ty, lba, declsa, rba),
2460 (B.StructUnion (sub, sbopt, declsb), ii) ->
2462 let (ii_sub_sb, lbb, rbb) =
2464 [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
2465 | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
2466 | _ -> failwith "list of length 3 or 4 expected" in
2469 match (sbopt,ii_sub_sb) with
2470 (None,Common.Left iisub) ->
2471 (* the following doesn't reconstruct the complete SP code, just
2472 the part that matched *)
2474 match A.unwrap s with
2476 (match A.unwrap ty with
2477 A.StructUnionName(sua, None) ->
2478 tokenf sua iisub >>= (fun sua iisub ->
2481 A.StructUnionName(sua, None) +> A.rewrap ty)
2483 return (ty,[iisub]))
2485 | A.DisjType(disjs) ->
2487 List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
2491 | (Some sb,Common.Right (iisub,iisb)) ->
2493 (* build a StructUnionName from a StructUnion *)
2494 let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
2496 fullType ty fake_su >>= (fun ty fake_su ->
2498 | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
2499 return (ty, [iisub; iisb])
2500 | _ -> raise Impossible)
2504 >>= (fun ty ii_sub_sb ->
2506 tokenf lba lbb >>= (fun lba lbb ->
2507 tokenf rba rbb >>= (fun rba rbb ->
2508 struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
2509 let declsa = redots declsa undeclsa in
2512 (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
2513 (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
2517 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2518 * uint in the C code. But some CEs consists in renaming some types,
2519 * so we don't want apply isomorphisms every time.
2521 | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
2522 let (isb) = tuple_of_list1 ii in
2525 tokenf sa isb >>= (fun sa isb ->
2527 (A.TypeName sa) +> A.rewrap ta,
2528 (B.TypeName (sb,typb), [isb])
2532 | _, (B.TypeOfExpr e, ii) -> fail
2533 | _, (B.TypeOfType e, ii) -> fail
2537 (* todo: iso on sign, if not mentioned then free. tochange?
2538 * but that require to know if signed int because explicit
2539 * signed int, or because implicit signed int.
2542 and sign signa signb =
2543 match signa, signb with
2544 | None, None -> return (None, [])
2545 | Some signa, Some (signb, ib) ->
2546 if equal_sign (term signa) signb
2547 then tokenf signa ib >>= (fun signa ib ->
2548 return (Some signa, [ib])
2554 and minusize_list iixs =
2555 iixs +> List.fold_left (fun acc ii ->
2556 acc >>= (fun xs ys ->
2557 tokenf minusizer ii >>= (fun minus ii ->
2558 return (minus::xs, ii::ys)
2559 ))) (return ([],[]))
2560 >>= (fun _xsminys ys ->
2561 return ((), List.rev ys)
2564 and storage_optional_allminus allminus stoa (stob, iistob) =
2565 (* "iso-by-absence" for storage, and return type. *)
2566 X.optional_storage_flag (fun optional_storage ->
2567 match stoa, stob with
2568 | None, (stobis, inline) ->
2572 minusize_list iistob >>= (fun () iistob ->
2573 return (None, (stob, iistob))
2575 else return (None, (stob, iistob))
2578 (match optional_storage, stobis with
2579 | false, B.NoSto -> do_minus ()
2581 | true, B.NoSto -> do_minus ()
2584 then pr2_once "USING optional_storage builtin isomorphism";
2588 | Some x, ((stobis, inline)) ->
2589 if equal_storage (term x) stobis
2593 tokenf x i1 >>= (fun x i1 ->
2594 return (Some x, ((stobis, inline), [i1]))
2596 (* or if have inline ? have to do a split_storage_inline a la
2597 * split_signb_baseb_ii *)
2598 | _ -> raise Impossible
2606 and fullType_optional_allminus allminus tya retb =
2611 X.distrf_type minusizer retb >>= (fun _x retb ->
2615 else return (None, retb)
2617 fullType tya retb >>= (fun tya retb ->
2618 return (Some tya, retb)
2623 (*---------------------------------------------------------------------------*)
2624 and compatible_type a (b,_local) =
2625 let ok = return ((),()) in
2627 let rec loop = function
2628 | Type_cocci.BaseType (a, signa), (qua, (B.BaseType b,ii)) ->
2630 | Type_cocci.VoidType, B.Void ->
2631 assert (signa = None);
2633 | Type_cocci.CharType, B.IntType B.CChar when signa = None ->
2635 | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
2636 compatible_sign signa signb
2637 | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
2638 compatible_sign signa signb
2639 | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
2640 compatible_sign signa signb
2641 | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
2642 compatible_sign signa signb
2643 | _, B.IntType (B.Si (signb, B.CLongLong)) ->
2644 pr2_once "no longlong in cocci";
2646 | Type_cocci.FloatType, B.FloatType B.CFloat ->
2647 assert (signa = None);
2649 | Type_cocci.DoubleType, B.FloatType B.CDouble ->
2650 assert (signa = None);
2652 | _, B.FloatType B.CLongDouble ->
2653 pr2_once "no longdouble in cocci";
2655 | Type_cocci.BoolType, _ -> failwith "no booltype in C"
2659 | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
2661 | Type_cocci.FunctionPointer a, _ ->
2663 "TODO: function pointer type doesn't store enough information to determine compatability"
2664 | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
2665 (* no size info for cocci *)
2667 | Type_cocci.StructUnionName (sua, _, sa),
2668 (qub, (B.StructUnionName (sub, sb),ii)) ->
2669 if equal_structUnion_type_cocci sua sub && sa = sb
2673 | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
2678 | Type_cocci.ConstVol (qua, a), (qub, b) ->
2679 if (fst qub).B.const && (fst qub).B.volatile
2682 pr2_once ("warning: the type is both const & volatile but cocci " ^
2683 "does not handle that");
2689 | Type_cocci.Const -> (fst qub).B.const
2690 | Type_cocci.Volatile -> (fst qub).B.volatile
2692 then loop (a,(Ast_c.nQ, b))
2695 | Type_cocci.MetaType (ida,keep,inherited), typb ->
2697 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
2698 X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
2702 (* subtil: must be after the MetaType case *)
2703 | a, (qub, (B.TypeName (sb,Some b), ii)) ->
2704 (* kind of typedef iso *)
2711 (* for metavariables of type expression *^* *)
2712 | Type_cocci.Unknown , _ -> ok
2717 and compatible_sign signa signb =
2718 let ok = return ((),()) in
2719 match signa, signb with
2721 | Some Type_cocci.Signed, B.Signed
2722 | Some Type_cocci.Unsigned, B.UnSigned
2727 and equal_structUnion_type_cocci a b =
2729 | Type_cocci.Struct, B.Struct -> true
2730 | Type_cocci.Union, B.Union -> true
2735 (*---------------------------------------------------------------------------*)
2736 and inc_file (a, before_after) (b, h_rel_pos) =
2738 let rec aux_inc (ass, bss) passed =
2742 let passed = List.rev passed in
2744 (match before_after, !h_rel_pos with
2745 | IncludeNothing, _ -> true
2746 | IncludeMcodeBefore, Some x ->
2747 List.mem passed (x.Ast_c.first_of)
2749 | IncludeMcodeAfter, Some x ->
2750 List.mem passed (x.Ast_c.last_of)
2752 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
2756 | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
2757 | _ -> failwith "IncDots not in last place or other pb"
2762 | A.Local ass, B.Local bss ->
2763 aux_inc (ass, bss) []
2764 | A.NonLocal ass, B.NonLocal bss ->
2765 aux_inc (ass, bss) []
2770 (*---------------------------------------------------------------------------*)
2772 and (define_params: sequence ->
2773 (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
2774 fun seqstyle eas ebs ->
2776 | Unordered -> failwith "not handling ooo"
2778 define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
2779 return (eas, (Ast_c.unsplit_comma ebs_splitted))
2782 (* todo? facto code with argument and parameters ? *)
2783 and define_paramsbis = fun eas ebs ->
2785 | [], [] -> return ([], [])
2786 | [], eb::ebs -> fail
2788 X.all_bound (A.get_inherited ea) >&&>
2789 (match A.unwrap ea, ebs with
2790 | A.DPdots (mcode), ys ->
2792 (* '...' can take more or less the beginnings of the arguments *)
2793 let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
2794 startendxs +> List.fold_left (fun acc (startxs, endxs) ->
2799 if mcode_contain_plus (mcodekind mcode)
2801 (* failwith "I have no token that I could accroche myself on" *)
2802 else return (dots2metavar mcode, [])
2804 (match Common.last startxs with
2807 X.distrf_define_params (dots2metavar mcode) startxs
2809 ) >>= (fun mcode startxs ->
2810 let mcode = metavar2dots mcode in
2811 define_paramsbis eas endxs >>= (fun eas endxs ->
2813 (A.DPdots (mcode) +> A.rewrap ea) ::eas,
2819 | A.DPComma ia1, Right ii::ebs ->
2820 let ib1 = tuple_of_list1 ii in
2821 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
2822 define_paramsbis eas ebs >>= (fun eas ebs ->
2824 (A.DPComma ia1 +> A.rewrap ea)::eas,
2829 | A.DPComma ia1, ebs ->
2830 if mcode_contain_plus (mcodekind ia1)
2833 (define_paramsbis eas ebs) (* try optional comma trick *)
2835 | (A.OptDParam _ | A.UniqueDParam _), _ ->
2836 failwith "handling Opt/Unique for define parameters"
2838 | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
2840 | A.DParam ida, (Left (idb, ii))::ebs ->
2841 let ib1 = tuple_of_list1 ii in
2842 ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
2843 define_paramsbis eas ebs >>= (fun eas ebs ->
2845 (A.DParam ida)+> A.rewrap ea :: eas,
2846 (Left (idb, [ib1]))::ebs
2849 | _unwrapx, (Right y)::ys -> raise Impossible
2850 | _unwrapx, [] -> fail
2855 (*****************************************************************************)
2857 (*****************************************************************************)
2859 (* no global solution for positions here, because for a statement metavariable
2860 we want a MetaStmtVal, and for the others, it's not clear what we want *)
2862 let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
2865 x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
2867 X.all_bound (A.get_inherited re) >&&>
2870 match A.unwrap re, F.unwrap node with
2872 (* note: the order of the clauses is important. *)
2874 | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
2876 (* the metaRuleElem contains just '-' information. We dont need to add
2877 * stuff in the environment. If we need stuff in environment, because
2878 * there is a + S somewhere, then this will be done via MetaStmt, not
2880 * Can match TrueNode/FalseNode/... so must be placed before those cases.
2883 | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
2884 let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
2885 (match unwrap_node with
2887 | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
2889 if X.mode = PatternMode
2892 if mcode_contain_plus (mcodekind mcode)
2893 then failwith "try add stuff on fake node"
2894 (* minusize or contextize a fake node is ok *)
2897 | F.EndStatement None ->
2898 if X.mode = PatternMode then return default
2900 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
2901 if mcode_contain_plus (mcodekind mcode)
2903 let fake_info = Ast_c.fakeInfo() in
2904 distrf distrf_node (mcodekind mcode)
2905 (F.EndStatement (Some fake_info))
2906 else return unwrap_node
2910 | F.EndStatement (Some i1) ->
2911 tokenf mcode i1 >>= (fun mcode i1 ->
2913 A.MetaRuleElem (mcode,keep, inherited),
2914 F.EndStatement (Some i1)
2918 if X.mode = PatternMode then return default
2919 else failwith "a MetaRuleElem can't transform a headfunc"
2921 if X.mode = PatternMode then return default
2923 X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
2925 A.MetaRuleElem(mcode,keep, inherited),
2931 (* rene cant have found that a state containing a fake/exit/... should be
2933 * TODO: and F.Fake ?
2935 | _, F.EndStatement _ | _, F.CaseNode _
2936 | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
2940 (* really ? diff between pattern.ml and transformation.ml *)
2941 | _, F.Fake -> fail2()
2944 (* cas general: a Meta can match everything. It matches only
2945 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
2946 * So can't have been called in transform.
2948 | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
2950 | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
2951 (* todo: should not happen in transform mode *)
2953 (match Control_flow_c.extract_fullstatement node with
2956 Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
2957 X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
2959 (* no need tag ida, we can't be called in transform-mode *)
2961 A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
2969 | A.MetaStmtList _, _ ->
2970 failwith "not handling MetaStmtList"
2972 | A.TopExp ea, F.DefineExpr eb ->
2973 expression ea eb >>= (fun ea eb ->
2979 | A.TopExp ea, F.DefineType eb ->
2980 (match A.unwrap ea with
2982 fullType ft eb >>= (fun ft eb ->
2984 A.TopExp (A.rewrap ea (A.TypeExp(ft))),
2991 (* It is important to put this case before the one that fails because
2992 * of the lack of the counter part of a C construct in SmPL (for instance
2993 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
2994 * yet certain constructs, those constructs may contain expression
2995 * that we still want and can transform.
2998 | A.Exp exp, nodeb ->
3000 (* kind of iso, initialisation vs affectation *)
3002 match A.unwrap exp, nodeb with
3003 | A.Assignment (ea, op, eb, true), F.Decl decl ->
3004 initialisation_to_affectation decl +> F.rewrap node
3009 (* Now keep fullstatement inside the control flow node,
3010 * so that can then get in a MetaStmtVar the fullstatement to later
3011 * pp back when the S is in a +. But that means that
3012 * Exp will match an Ifnode even if there is no such exp
3013 * inside the condition of the Ifnode (because the exp may
3014 * be deeper, in the then branch). So have to not visit
3015 * all inside a node anymore.
3017 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3018 * fois le fullstatement et le partialstatement et appeler le
3019 * visiteur que sur le partialstatement.
3022 match Ast_cocci.get_pos re with
3023 | None -> expression
3027 Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
3028 let keep = Type_cocci.Unitary in
3029 let inherited = false in
3030 let max_min _ = failwith "no pos" in
3031 X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
3037 X.cocciExp expfn exp node >>= (fun exp node ->
3047 X.cocciTy fullType ty node >>= (fun ty node ->
3055 | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
3056 F.FunHeader ((idb, (retb, (paramsb, (isvaargs, iidotsb))), stob), ii) ->
3058 (* fninfoa records the order in which the SP specified the various
3059 information, but this isn't taken into account in the matching.
3060 Could this be a problem for transformation? *)
3063 List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
3064 with [A.FStorage(s)] -> Some s | _ -> None in
3066 match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
3067 with [A.FType(t)] -> Some t | _ -> None in
3069 (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
3070 with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
3072 (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
3073 with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
3076 | iidb::ioparenb::icparenb::iifakestart::iistob ->
3078 (* maybe important to put ident as the first tokens to transform.
3079 * It's related to transform_proto. So don't change order
3082 ident LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
3083 X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
3084 tokenf oparen ioparenb >>= (fun oparen ioparenb ->
3085 tokenf cparen icparenb >>= (fun cparen icparenb ->
3086 parameters (seqstyle paramsa)
3087 (A.undots paramsa) paramsb >>=
3088 (fun paramsaundots paramsb ->
3089 let paramsa = redots paramsa paramsaundots in
3090 storage_optional_allminus allminus
3091 stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
3096 ("Not handling well variable length arguments func. "^
3097 "You have been warned");
3099 then minusize_list iidotsb
3100 else return ((),iidotsb)
3101 ) >>= (fun () iidotsb ->
3103 fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
3106 (match stoa with Some st -> [A.FStorage st] | None -> []) ++
3107 (match tya with Some t -> [A.FType t] | None -> [])
3112 A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
3114 F.FunHeader ((idb, (retb, (paramsb, (isvaargs, iidotsb))),
3116 iidb::ioparenb::icparenb::iifakestart::iistob)
3119 | _ -> raise Impossible
3127 | A.Decl (mckstart,allminus,decla), F.Decl declb ->
3128 declaration (mckstart,allminus,decla) declb >>=
3129 (fun (mckstart,allminus,decla) declb ->
3131 A.Decl (mckstart,allminus,decla),
3136 | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
3137 tokenf mcode i1 >>= (fun mcode i1 ->
3140 F.SeqStart (st, level, i1)
3143 | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
3144 tokenf mcode i1 >>= (fun mcode i1 ->
3147 F.SeqEnd (level, i1)
3150 | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
3151 let ib1 = tuple_of_list1 ii in
3152 expression ea eb >>= (fun ea eb ->
3153 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3155 A.ExprStatement (ea, ia1),
3156 F.ExprStatement (st, (Some eb, [ib1]))
3161 | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
3162 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3163 expression ea eb >>= (fun ea eb ->
3164 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3165 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3166 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3168 A.IfHeader (ia1, ia2, ea, ia3),
3169 F.IfHeader (st, (eb,[ib1;ib2;ib3]))
3172 | A.Else ia, F.Else ib ->
3173 tokenf ia ib >>= (fun ia ib ->
3174 return (A.Else ia, F.Else ib)
3177 | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
3178 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3179 expression ea eb >>= (fun ea eb ->
3180 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3181 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3182 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3184 A.WhileHeader (ia1, ia2, ea, ia3),
3185 F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
3188 | A.DoHeader ia, F.DoHeader (st, ib) ->
3189 tokenf ia ib >>= (fun ia ib ->
3194 | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
3195 let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
3196 expression ea eb >>= (fun ea eb ->
3197 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3198 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3199 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3200 tokenf ia4 ib4 >>= (fun ia4 ib4 ->
3202 A.WhileTail (ia1,ia2,ea,ia3,ia4),
3203 F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
3205 | A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
3207 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3209 ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
3210 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3211 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3212 arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
3213 let eas = redots eas easundots in
3215 A.IteratorHeader (ia1, ia2, eas, ia3),
3216 F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
3221 | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
3222 F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
3224 assert (null ib4vide);
3225 let (ib1, ib2, ib5) = tuple_of_list3 ii in
3226 let ib3 = tuple_of_list1 ib3s in
3227 let ib4 = tuple_of_list1 ib4s in
3229 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3230 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3231 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3232 tokenf ia4 ib4 >>= (fun ia4 ib4 ->
3233 tokenf ia5 ib5 >>= (fun ia5 ib5 ->
3234 option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
3235 option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
3236 option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
3238 A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
3239 F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
3245 | A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
3246 let (ib1, ib2, ib3) = tuple_of_list3 ii in
3247 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3248 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3249 tokenf ia3 ib3 >>= (fun ia3 ib3 ->
3250 expression ea eb >>= (fun ea eb ->
3252 A.SwitchHeader(ia1,ia2,ea,ia3),
3253 F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
3256 | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
3257 let (ib1, ib2) = tuple_of_list2 ii in
3258 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3259 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3262 F.Break (st, ((),[ib1;ib2]))
3265 | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
3266 let (ib1, ib2) = tuple_of_list2 ii in
3267 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3268 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3270 A.Continue (ia1, ia2),
3271 F.Continue (st, ((),[ib1;ib2]))
3274 | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
3275 let (ib1, ib2) = tuple_of_list2 ii in
3276 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3277 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3279 A.Return (ia1, ia2),
3280 F.Return (st, ((),[ib1;ib2]))
3283 | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
3284 let (ib1, ib2) = tuple_of_list2 ii in
3285 tokenf ia1 ib1 >>= (fun ia1 ib1 ->
3286 tokenf ia2 ib2 >>= (fun ia2 ib2 ->
3287 expression ea eb >>= (fun ea eb ->
3289 A.ReturnExpr (ia1, ea, ia2),
3290 F.ReturnExpr (st, (eb, [ib1;ib2]))
3295 | A.Include(incla,filea), F.Include ((fileb, ii), (h_rel_pos, inifdef)) ->
3297 let include_requirment =
3298 match mcodekind incla, mcodekind filea with
3299 | A.CONTEXT (_, A.BEFORE _), _ ->
3301 | _, A.CONTEXT (_, A.AFTER _) ->
3307 let (inclb, iifileb) = tuple_of_list2 ii in
3308 if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
3310 tokenf incla inclb >>= (fun incla inclb ->
3311 tokenf filea iifileb >>= (fun filea iifileb ->
3313 A.Include(incla, filea),
3314 F.Include ((fileb, [inclb;iifileb]), (h_rel_pos, inifdef))
3320 | A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
3321 let (defineb, iidb, ieol) = tuple_of_list3 ii in
3322 ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
3323 tokenf definea defineb >>= (fun definea defineb ->
3324 (match A.unwrap params, defkind with
3325 | A.NoParams, B.DefineVar ->
3327 A.NoParams +> A.rewrap params,
3330 | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
3331 let (lpb, rpb) = tuple_of_list2 ii in
3332 tokenf lpa lpb >>= (fun lpa lpb ->
3333 tokenf rpa rpb >>= (fun rpa rpb ->
3335 define_params (seqstyle eas) (A.undots eas) ebs >>=
3336 (fun easundots ebs ->
3337 let eas = redots eas easundots in
3339 A.DParams (lpa,eas,rpa) +> A.rewrap params,
3340 B.DefineFunc (ebs,[lpb;rpb])
3344 ) >>= (fun params defkind ->
3346 A.DefineHeader (definea, ida, params),
3347 F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
3352 | A.Default(def,colon), F.Default (st, ((),ii)) ->
3353 let (ib1, ib2) = tuple_of_list2 ii in
3354 tokenf def ib1 >>= (fun def ib1 ->
3355 tokenf colon ib2 >>= (fun colon ib2 ->
3357 A.Default(def,colon),
3358 F.Default (st, ((),[ib1;ib2]))
3363 | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
3364 let (ib1, ib2) = tuple_of_list2 ii in
3365 tokenf case ib1 >>= (fun case ib1 ->
3366 expression ea eb >>= (fun ea eb ->
3367 tokenf colon ib2 >>= (fun colon ib2 ->
3369 A.Case(case,ea,colon),
3370 F.Case (st, (eb,[ib1;ib2]))
3373 (* only occurs in the predicates generated by asttomember *)
3374 | A.DisjRuleElem eas, _ ->
3376 List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
3377 >>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
3379 | _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
3381 | A.Label(id,dd), F.Label (st,(s,ii)) ->
3382 let (ib1,ib2) = tuple_of_list2 ii in
3383 let (string_of_id,rebuild) =
3384 match A.unwrap id with
3385 A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
3386 | _ -> failwith "labels with metavariables not supported" in
3387 if (term string_of_id) =$= s
3389 tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
3390 tokenf dd ib2 >>= (fun dd ib2 ->
3392 A.Label(rebuild string_of_id,dd),
3393 F.Label (st,(s,[ib1;ib2]))
3397 | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
3398 let (ib1,ib2,ib3) = tuple_of_list3 ii in
3399 tokenf goto ib1 >>= (fun goto ib1 ->
3400 ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
3401 tokenf sem ib3 >>= (fun sem ib3 ->
3403 A.Goto(goto,id,sem),
3404 F.Goto (st,(s,[ib1;ib2;ib3]))
3407 (* have not a counter part in coccinelle, for the moment *)
3408 (* todo?: print a warning at least ? *)