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.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
550 A.keep_binding
-> A.inherited
->
551 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
552 (unit -> Common.filename
* Ast_c.posl
* Ast_c.posl
) ->
553 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
555 val check_constraints
:
556 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
557 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
559 val all_bound
: A.meta_name list
-> (tin
-> bool)
561 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
562 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
563 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
568 (*****************************************************************************)
569 (* Functor code, "Cocci vs C" *)
570 (*****************************************************************************)
573 functor (X
: PARAM
) ->
576 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
579 let return = X.return
582 let (>||>) = X.(>||>)
583 let (>|+|>) = X.(>|+|>)
584 let (>&&>) = X.(>&&>)
586 let tokenf = X.tokenf
588 (* should be raise Impossible when called from transformation.ml *)
591 | PatternMode
-> fail
592 | TransformMode
-> raise Impossible
595 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
597 | (Some t1
, Some t2
) ->
598 f t1 t2
>>= (fun t1 t2
->
599 return (Some t1
, Some t2
)
601 | (None
, None
) -> return (None
, None
)
604 (* Dots are sometimes used as metavariables, since like metavariables they
605 can match other things. But they no longer have the same type. Perhaps these
606 functions could be avoided by introducing an appropriate level of polymorphism,
607 but I don't know how to declare polymorphism across functors *)
608 let dots2metavar (_
,info
,mcodekind,pos
) = (("","..."),info
,mcodekind,pos
)
609 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
611 (*---------------------------------------------------------------------------*)
623 (*---------------------------------------------------------------------------*)
624 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
626 X.all_bound
(A.get_inherited ea
) >&&>
627 let wa x
= A.rewrap ea x
in
628 match A.unwrap ea
, eb
with
630 (* general case: a MetaExpr can match everything *)
631 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
632 (((expr
, opttypb
), ii
) as expb
) ->
634 (* old: before have a MetaConst. Now we factorize and use 'form' to
635 * differentiate between different cases *)
636 let rec matches_id = function
638 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
641 match (form
,expr
) with
644 let rec matches = function
645 B.Constant
(c
) -> true
646 | B.Ident idb
when idb
=~
"^[A-Z_][A-Z_0-9]*$" ->
647 pr2_once
("warning: I consider " ^ idb ^
" as a constant");
649 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
650 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
651 | B.SizeOfExpr
(exp
) -> true
652 | B.SizeOfType
(ty
) -> true
658 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
660 | (A.ID
,e
) -> matches_id e
in
664 (let (opttypb
,_testb
) = !opttypb
in
665 match opttypa
, opttypb
with
666 | None
, _
-> return ((),())
668 pr2_once
("Missing type information. Certainly a pb in " ^
669 "annotate_typer.ml");
672 | Some tas
, Some tb
->
673 tas
+> List.fold_left
(fun acc ta
->
674 acc
>|+|> compatible_type ta tb
) fail
677 X.check_constraints expression constraints eb
680 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
681 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
683 X.distrf_e ida expb
>>= (fun ida expb
->
685 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
693 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
694 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
696 * but bug! because if have not tagged SP, then transform without doing
697 * any checks. Hopefully now have tagged SP technique.
702 * | A.Edots _, _ -> raise Impossible.
704 * In fact now can also have the Edots inside normal expression, not
705 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
707 | A.Edots
(mcode
, None
), expb
->
708 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
710 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
715 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
718 | A.Ident ida
, ((B.Ident idb
, typ),ii
) ->
719 let ib1 = tuple_of_list1 ii
in
720 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
722 ((A.Ident ida
)) +> wa,
723 ((B.Ident idb
, typ),[ib1])
729 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
731 (* todo?: handle some isomorphisms in int/float ? can have different
732 * format : 1l can match a 1.
734 * todo: normally string can contain some metavar too, so should
735 * recurse on the string
737 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
738 (* for everything except the String case where can have multi elems *)
740 let ib1 = tuple_of_list1 ii
in
741 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
743 ((A.Constant ia1
)) +> wa,
744 ((B.Constant
(ib
), typ),[ib1])
747 (match term ia1
, ib
with
748 | A.Int x
, B.Int y
->
749 X.value_format_flag
(fun use_value_equivalence
->
750 if use_value_equivalence
760 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
762 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
765 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
768 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
770 ((A.Constant ia1
)) +> wa,
771 ((B.Constant
(ib
), typ),[ib1])
773 | _
-> fail (* multi string, not handled *)
779 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
780 (* todo: do special case to allow IdMetaFunc, cos doing the
781 * recursive call will be too late, match_ident will not have the
782 * info whether it was a function. todo: but how detect when do
783 * x.field = f; how know that f is a Func ? By having computed
784 * some information before the matching!
786 * Allow match with FunCall containing types. Now ast_cocci allow
787 * type in parameter, and morover ast_cocci allow f(...) and those
788 * ... could match type.
790 let (ib1, ib2
) = tuple_of_list2 ii
in
791 expression ea eb
>>= (fun ea eb
->
792 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
793 tokenf ia2 ib2
>>= (fun ia2 ib2
->
794 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
795 let eas = redots
eas easundots
in
797 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
798 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
804 | A.Assignment
(ea1
, opa
, ea2
, simple
),
805 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
806 let (opbi
) = tuple_of_list1 ii
in
807 if equal_assignOp (term opa
) opb
809 expression ea1 eb1
>>= (fun ea1 eb1
->
810 expression ea2 eb2
>>= (fun ea2 eb2
->
811 tokenf opa opbi
>>= (fun opa opbi
->
813 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
814 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
818 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
819 let (ib1, ib2
) = tuple_of_list2 ii
in
820 expression ea1 eb1
>>= (fun ea1 eb1
->
821 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
822 expression ea3 eb3
>>= (fun ea3 eb3
->
823 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
824 tokenf ia2 ib2
>>= (fun ia2 ib2
->
826 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
827 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
830 (* todo?: handle some isomorphisms here ? *)
831 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
832 let opbi = tuple_of_list1 ii
in
833 if equal_fixOp (term opa
) opb
835 expression ea eb
>>= (fun ea eb
->
836 tokenf opa
opbi >>= (fun opa
opbi ->
838 ((A.Postfix
(ea
, opa
))) +> wa,
839 ((B.Postfix
(eb
, opb
), typ),[opbi])
844 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
845 let opbi = tuple_of_list1 ii
in
846 if equal_fixOp (term opa
) opb
848 expression ea eb
>>= (fun ea eb
->
849 tokenf opa
opbi >>= (fun opa
opbi ->
851 ((A.Infix
(ea
, opa
))) +> wa,
852 ((B.Infix
(eb
, opb
), typ),[opbi])
856 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
857 let opbi = tuple_of_list1 ii
in
858 if equal_unaryOp (term opa
) opb
860 expression ea eb
>>= (fun ea eb
->
861 tokenf opa
opbi >>= (fun opa
opbi ->
863 ((A.Unary
(ea
, opa
))) +> wa,
864 ((B.Unary
(eb
, opb
), typ),[opbi])
868 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
869 let opbi = tuple_of_list1 ii
in
870 if equal_binaryOp (term opa
) opb
872 expression ea1 eb1
>>= (fun ea1 eb1
->
873 expression ea2 eb2
>>= (fun ea2 eb2
->
874 tokenf opa
opbi >>= (fun opa
opbi ->
876 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
877 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
881 | A.Nested
(ea1
, opa
, ea2
), eb
->
883 (if A.get_test_exp ea1
&& not
(Ast_c.is_test eb
) then fail
884 else expression ea1 eb
) >|+|>
886 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
887 when equal_binaryOp (term opa
) opb
->
888 let opbi = tuple_of_list1 ii
in
890 (expression ea1 eb1
>>= (fun ea1 eb1
->
891 expression ea2 eb2
>>= (fun ea2 eb2
->
892 tokenf opa
opbi >>= (fun opa
opbi ->
894 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
895 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
898 (expression ea2 eb1
>>= (fun ea2 eb1
->
899 expression ea1 eb2
>>= (fun ea1 eb2
->
900 tokenf opa
opbi >>= (fun opa
opbi ->
902 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
903 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
906 (loop eb1
>>= (fun ea1 eb1
->
907 expression ea2 eb2
>>= (fun ea2 eb2
->
908 tokenf opa
opbi >>= (fun opa
opbi ->
910 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
911 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
914 (expression ea2 eb1
>>= (fun ea2 eb1
->
915 loop eb2
>>= (fun ea1 eb2
->
916 tokenf opa
opbi >>= (fun opa
opbi ->
918 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
919 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
921 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
925 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
926 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
927 let (ib1, ib2
) = tuple_of_list2 ii
in
928 expression ea1 eb1
>>= (fun ea1 eb1
->
929 expression ea2 eb2
>>= (fun ea2 eb2
->
930 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
931 tokenf ia2 ib2
>>= (fun ia2 ib2
->
933 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
934 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
937 (* todo?: handle some isomorphisms here ? *)
938 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
939 let (ib1, ib2
) = tuple_of_list2 ii
in
940 ident DontKnow ida
(idb
, ib2
) >>= (fun ida
(idb
, ib2
) ->
941 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
942 expression ea eb
>>= (fun ea eb
->
944 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
945 ((B.RecordAccess
(eb
, idb
), typ), [ib1;ib2
])
950 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
951 let (ib1, ib2
) = tuple_of_list2 ii
in
952 ident DontKnow ida
(idb
, ib2
) >>= (fun ida
(idb
, ib2
) ->
953 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
954 expression ea eb
>>= (fun ea eb
->
956 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
957 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1;ib2
])
961 (* todo?: handle some isomorphisms here ?
962 * todo?: do some iso-by-absence on cast ?
963 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
966 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
967 let (ib1, ib2
) = tuple_of_list2 ii
in
968 fullType typa typb
>>= (fun typa typb
->
969 expression ea eb
>>= (fun ea eb
->
970 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
971 tokenf ia2 ib2
>>= (fun ia2 ib2
->
973 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
974 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
977 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
978 let ib1 = tuple_of_list1 ii
in
979 expression ea eb
>>= (fun ea eb
->
980 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
982 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
983 ((B.SizeOfExpr
(eb
), typ),[ib1])
986 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
987 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
988 fullType typa typb
>>= (fun typa typb
->
989 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
990 tokenf ia2 ib2
>>= (fun ia2 ib2
->
991 tokenf ia3 ib3
>>= (fun ia3 ib3
->
993 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
994 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
998 (* todo? iso ? allow all the combinations ? *)
999 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1000 let (ib1, ib2
) = tuple_of_list2 ii
in
1001 expression ea eb
>>= (fun ea eb
->
1002 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1003 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1005 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1006 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1009 | A.NestExpr
(exps
,None
,true), eb
->
1010 (match A.unwrap exps
with
1012 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1014 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1020 "for nestexpr, only handling the case with dots and only one exp")
1022 | A.NestExpr _
, _
->
1023 failwith
"only handling multi and no when code in a nest expr"
1025 (* only in arg lists or in define body *)
1026 | A.TypeExp _
, _
-> fail
1028 (* only in arg lists *)
1029 | A.MetaExprList _
, _
1036 | A.DisjExpr
eas, eb
->
1037 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1039 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1040 failwith
"not handling Opt/Unique/Multi on expr"
1042 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1044 (* have not a counter part in coccinelle, for the moment *)
1045 | _
, ((B.Sequence _
,_
),_
)
1046 | _
, ((B.StatementExpr _
,_
),_
)
1047 | _
, ((B.Constructor _
,_
),_
)
1054 (* ------------------------------------------------------------------------- *)
1055 and (ident
: info_ident
-> (A.ident
, string * Ast_c.info
) matcher
) =
1056 fun infoidb ida
((idb
, iib
) as ib
) ->
1057 X.all_bound
(A.get_inherited ida
) >&&>
1058 match A.unwrap ida
with
1060 if (term sa
) =$
= idb
then
1061 tokenf sa iib
>>= (fun sa iib
->
1063 ((A.Id sa
)) +> A.rewrap ida
,
1069 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1070 X.check_constraints
(ident infoidb
) constraints ib
1072 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1073 (* use drop_pos for ids so that the pos is not added a second time in
1074 the call to tokenf *)
1075 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1077 tokenf mida iib
>>= (fun mida iib
->
1079 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1084 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1086 X.check_constraints
(ident infoidb
) constraints ib
1088 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1089 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1091 tokenf mida iib
>>= (fun mida iib
->
1093 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1098 | LocalFunction
| Function
-> is_function()
1100 failwith
"MetaFunc, need more semantic info about id"
1101 (* the following implementation could possibly be useful, if one
1102 follows the convention that a macro is always in capital letters
1103 and that a macro is not a function.
1104 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1107 | A.MetaLocalFunc
(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 X.envf keep inherited
1114 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1116 tokenf mida iib
>>= (fun mida iib
->
1118 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1124 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1127 | A.OptIdent _
| A.UniqueIdent _
->
1128 failwith
"not handling Opt/Unique for ident"
1132 (* ------------------------------------------------------------------------- *)
1133 and (arguments
: sequence
->
1134 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1135 fun seqstyle eas ebs
->
1137 | Unordered
-> failwith
"not handling ooo"
1139 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1140 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1142 (* because '...' can match nothing, need to take care when have
1143 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1144 * f(1,2) for instance.
1145 * So I have added special cases such as (if startxs = []) and code
1146 * in the Ecomma matching rule.
1148 * old: Must do some try, for instance when f(...,X,Y,...) have to
1149 * test the transfo for all the combinaitions and if multiple transfo
1150 * possible ? pb ? => the type is to return a expression option ? use
1151 * some combinators to help ?
1152 * update: with the tag-SP approach, no more a problem.
1155 and arguments_bis
= fun eas ebs
->
1157 | [], [] -> return ([], [])
1158 | [], eb
::ebs
-> fail
1160 X.all_bound
(A.get_inherited ea
) >&&>
1161 (match A.unwrap ea
, ebs
with
1162 | A.Edots
(mcode
, optexpr
), ys
->
1163 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1164 if optexpr
<> None
then failwith
"not handling when in argument";
1166 (* '...' can take more or less the beginnings of the arguments *)
1167 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1168 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1171 (* allow '...', and maybe its associated ',' to match nothing.
1172 * for the associated ',' see below how we handle the EComma
1177 if mcode_contain_plus (mcodekind mcode
)
1179 (* failwith "I have no token that I could accroche myself on" *)
1180 else return (dots2metavar mcode
, [])
1182 (* subtil: we dont want the '...' to match until the
1183 * comma. cf -test pb_params_iso. We would get at
1184 * "already tagged" error.
1185 * this is because both f (... x, ...) and f (..., x, ...)
1186 * would match a f(x,3) with our "optional-comma" strategy.
1188 (match Common.last startxs
with
1191 X.distrf_args
(dots2metavar mcode
) startxs
1194 >>= (fun mcode startxs
->
1195 let mcode = metavar2dots mcode in
1196 arguments_bis
eas endxs
>>= (fun eas endxs
->
1198 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1204 | A.EComma ia1
, Right ii
::ebs
->
1205 let ib1 = tuple_of_list1 ii
in
1206 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1207 arguments_bis
eas ebs
>>= (fun eas ebs
->
1209 (A.EComma ia1
+> A.rewrap ea
)::eas,
1213 | A.EComma ia1
, ebs
->
1214 (* allow ',' to maching nothing. optional comma trick *)
1215 if mcode_contain_plus (mcodekind ia1
)
1217 else arguments_bis
eas ebs
1219 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1220 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1221 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1226 if mcode_contain_plus (mcodekind ida
)
1228 (* failwith "no token that I could accroche myself on" *)
1231 (match Common.last startxs
with
1239 let startxs'
= Ast_c.unsplit_comma
startxs in
1240 let len = List.length
startxs'
in
1243 | Some
(lenname
,lenkeep
,leninherited
) ->
1244 let max_min _
= failwith
"no pos" in
1245 X.envf lenkeep leninherited
1246 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1247 | None
-> function f
-> f
()
1251 Lib_parsing_c.lin_col_by_pos
1252 (Lib_parsing_c.ii_of_args
startxs) in
1253 X.envf keep inherited
1254 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1257 then return (ida
, [])
1258 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1260 >>= (fun ida
startxs ->
1261 arguments_bis
eas endxs
>>= (fun eas endxs
->
1263 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1264 +> A.rewrap ea
::eas,
1272 | _unwrapx
, (Left eb
)::ebs
->
1273 argument ea eb
>>= (fun ea eb
->
1274 arguments_bis
eas ebs
>>= (fun eas ebs
->
1275 return (ea
::eas, Left eb
::ebs
)
1277 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1278 | _unwrapx
, [] -> fail
1282 and argument arga argb
=
1283 X.all_bound
(A.get_inherited arga
) >&&>
1284 match A.unwrap arga
, argb
with
1285 | A.TypeExp tya
, Right
(B.ArgType
(((b
, sopt
, tyb
), ii_b_s
))) ->
1287 if b
|| sopt
<> None
1289 (* failwith "the argument have a storage and ast_cocci does not have"*)
1292 fullType tya tyb
>>= (fun tya tyb
->
1294 (A.TypeExp tya
) +> A.rewrap arga
,
1295 (Right
(B.ArgType
(((b
, sopt
, tyb
), ii_b_s
))))
1298 | A.TypeExp tya
, _
-> fail
1299 | _
, Right
(B.ArgType
(tyb
, sto_iisto
)) -> fail
1301 expression arga argb
>>= (fun arga argb
->
1302 return (arga
, Left argb
)
1304 | _
, Right
(B.ArgAction y
) -> fail
1307 (* ------------------------------------------------------------------------- *)
1308 (* todo? facto code with argument ? *)
1309 and (parameters
: sequence
->
1310 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1312 fun seqstyle eas ebs
->
1314 | Unordered
-> failwith
"not handling ooo"
1316 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1317 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1321 and parameters_bis
eas ebs
=
1323 | [], [] -> return ([], [])
1324 | [], eb
::ebs
-> fail
1326 (* the management of positions is inlined into each case, because
1327 sometimes there is a Param and sometimes a ParamList *)
1328 X.all_bound
(A.get_inherited ea
) >&&>
1329 (match A.unwrap ea
, ebs
with
1330 | A.Pdots
(mcode), ys
->
1332 (* '...' can take more or less the beginnings of the arguments *)
1333 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1334 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1339 if mcode_contain_plus (mcodekind mcode)
1341 (* failwith "I have no token that I could accroche myself on"*)
1342 else return (dots2metavar mcode, [])
1344 (match Common.last
startxs with
1347 X.distrf_params
(dots2metavar mcode) startxs
1349 ) >>= (fun mcode startxs ->
1350 let mcode = metavar2dots mcode in
1351 parameters_bis
eas endxs
>>= (fun eas endxs
->
1353 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1359 | A.PComma ia1
, Right ii
::ebs
->
1360 let ib1 = tuple_of_list1 ii
in
1361 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1362 parameters_bis
eas ebs
>>= (fun eas ebs
->
1364 (A.PComma ia1
+> A.rewrap ea
)::eas,
1369 | A.PComma ia1
, ebs
->
1370 (* try optional comma trick *)
1371 if mcode_contain_plus (mcodekind ia1
)
1373 else parameters_bis
eas ebs
1376 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1377 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1378 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1383 if mcode_contain_plus (mcodekind ida
)
1385 (* failwith "I have no token that I could accroche myself on" *)
1388 (match Common.last
startxs with
1396 let startxs'
= Ast_c.unsplit_comma
startxs in
1397 let len = List.length
startxs'
in
1400 Some
(lenname
,lenkeep
,leninherited
) ->
1401 let max_min _
= failwith
"no pos" in
1402 X.envf lenkeep leninherited
1403 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1404 | None
-> function f
-> f
()
1408 Lib_parsing_c.lin_col_by_pos
1409 (Lib_parsing_c.ii_of_params
startxs) in
1410 X.envf keep inherited
1411 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1414 then return (ida
, [])
1415 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1416 ) >>= (fun ida
startxs ->
1417 parameters_bis
eas endxs
>>= (fun eas endxs
->
1419 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1420 +> A.rewrap ea
::eas,
1428 | A.VoidParam ta
, ys
->
1429 (match eas, ebs
with
1431 let ((hasreg
, idbopt
, tb
), ii_b_s
) = eb
in
1432 if idbopt
= None
&& null ii_b_s
1435 | (qub
, (B.BaseType
B.Void
,_
)) ->
1436 fullType ta tb
>>= (fun ta tb
->
1438 [(A.VoidParam ta
) +> A.rewrap ea
],
1439 [Left
((hasreg
, idbopt
, tb
), ii_b_s
)]
1446 | (A.OptParam _
| A.UniqueParam _
), _
->
1447 failwith
"handling Opt/Unique for Param"
1449 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1452 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1453 (* todo: use quaopt, hasreg ? *)
1455 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1456 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1457 X.distrf_param ida eb
1458 ) >>= (fun ida eb
->
1459 parameters_bis
eas ebs
>>= (fun eas ebs
->
1461 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1466 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1467 (*this should succeed if the C code has a name, and fail otherwise*)
1468 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1469 parameters_bis
eas ebs
>>= (fun eas ebs
->
1471 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1475 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1476 | _unwrapx
, [] -> fail
1483 and parameter
= fun (idaopt
, typa
) ((hasreg
, idbopt
, typb
), ii_b_s
) ->
1484 fullType typa typb
>>= (fun typa typb
->
1485 match idaopt
, Ast_c.split_register_param
(hasreg
, idbopt
, ii_b_s
) with
1486 | Some ida
, Left
(idb
, iihasreg
, iidb
) ->
1487 (* todo: if minus on ida, should also minus the iihasreg ? *)
1488 ident DontKnow ida
(idb
,iidb
) >>= (fun ida
(idb
,iidb
) ->
1491 ((hasreg
, Some idb
, typb
), iihasreg
++[iidb
])
1494 | None
, Right iihasreg
->
1497 ((hasreg
, None
, typb
), iihasreg
)
1501 (* why handle this case ? because of transform_proto ? we may not
1502 * have an ident in the proto.
1503 * If have some plus on ida ? do nothing about ida ?
1505 (* not anymore !!! now that julia is handling the proto.
1506 | _, Right iihasreg ->
1509 ((hasreg, None, typb), iihasreg)
1513 | Some _
, Right _
-> fail
1514 | None
, Left _
-> fail
1520 (* ------------------------------------------------------------------------- *)
1521 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1522 fun (mckstart
, allminus
, decla
) declb
->
1523 X.all_bound
(A.get_inherited decla
) >&&>
1524 match A.unwrap decla
, declb
with
1526 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1527 * de toutes les declarations qui sont au debut d'un fonction et
1528 * commencer le reste du match au premier statement. Alors, ca matche
1529 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1530 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1532 * When the SP want to remove the whole function, the minus is not
1533 * on the MetaDecl but on the MetaRuleElem. So there should
1534 * be no transform of MetaDecl, just matching are allowed.
1537 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1538 (* todo: should not happen in transform mode *)
1539 return ((mckstart
, allminus
, decla
), declb
)
1543 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1544 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1545 (fun decla
(var
,iiptvirgb
,iisto
)->
1546 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1548 (mckstart
, allminus
, decla
),
1549 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1552 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1553 if X.mode
= PatternMode
1555 xs
+> List.fold_left
(fun acc var
->
1557 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1558 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1559 (fun decla
(var
, iiptvirgb
, iisto
) ->
1561 (mckstart
, allminus
, decla
),
1562 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1566 failwith
"More that one variable in decl. Have to split to transform."
1568 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1569 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1571 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1572 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1573 | _
-> raise Impossible
1576 then minusize_list iistob
1577 else return ((), iistob
)
1578 ) >>= (fun () iistob
->
1580 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1581 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1582 tokenf lpa lpb
>>= (fun lpa lpb
->
1583 tokenf rpa rpb
>>= (fun rpa rpb
->
1584 tokenf enda iiendb
>>= (fun enda iiendb
->
1585 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1586 let eas = redots
eas easundots
in
1589 (mckstart
, allminus
,
1590 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1591 (B.MacroDecl
((sb
,ebs
),
1592 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1599 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1600 X.all_bound
(A.get_inherited decla
) >&&>
1601 match A.unwrap decla
, declb
with
1603 (* kind of typedef iso, we must unfold, it's for the case
1604 * T { }; that we want to match against typedef struct { } xx_t;
1606 | A.TyDecl
(tya0
, ptvirga
),
1607 ((Some
((idb
, None
),[iidb
]), typb0
, (B.StoTypedef
, inl
), local), iivirg
) ->
1609 (match A.unwrap tya0
, typb0
with
1610 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1612 (match A.unwrap tya1
, typb1
with
1613 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1614 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1616 let (iisub
, iisbopt
, lbb
, rbb
) =
1619 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1620 (iisub
, [], lbb
, rbb
)
1623 "warning: both a typedef (%s) and struct name introduction (%s)"
1626 pr2
"warning: I will consider only the typedef";
1627 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1628 (iisub
, [iisb
], lbb
, rbb
)
1631 structdef_to_struct_name
1632 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1635 Ast_c.nQ
,((B.TypeName
(idb
, Some
1636 (Lib_parsing_c.al_type
structnameb))), [iidb
])
1639 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1640 tokenf lba lbb
>>= (fun lba lbb
->
1641 tokenf rba rbb
>>= (fun rba rbb
->
1642 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1643 let declsa = redots
declsa undeclsa
in
1645 (match A.unwrap tya2
with
1646 | A.Type
(cv3
, tya3
) ->
1647 (match A.unwrap tya3
with
1648 | A.MetaType
(ida
,keep
, inherited
) ->
1650 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1652 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1653 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1656 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1657 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1658 let typb0 = ((qu
, il
), typb1) in
1660 match fake_typeb with
1661 | _nQ
, ((B.TypeName
(idb
,_typ
)), [iidb
]) ->
1664 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1665 (((Some
((idb
, None
),[iidb
]), typb0, (B.StoTypedef
, inl
),
1667 iivirg
),iiptvirgb
,iistob
)
1669 | _
-> raise Impossible
1672 | A.StructUnionName
(sua
, sa
) ->
1674 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1676 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1678 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1680 match structnameb with
1681 | _nQ
, (B.StructUnionName
(sub
, s
), [iisub
;iisbopt
]) ->
1683 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1684 [iisub
;iisbopt
;lbb
;rbb
] in
1685 let typb0 = ((qu
, il
), typb1) in
1688 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1689 (((Some
((idb
, None
),[iidb
]), typb0,
1690 (B.StoTypedef
, inl
), local),
1691 iivirg
),iiptvirgb
,iistob
)
1693 | _
-> raise Impossible
1695 | _
-> raise Impossible
1704 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1705 ((Some
((idb
, _
),[iidb
]), typb
, (B.StoTypedef
,_
), _local
), iivirg
) ->
1708 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1709 ((Some
((idb
, _
),[iidb
]), typb
, (B.StoTypedef
,_
), _local
), iivirg
) ->
1714 (* could handle iso here but handled in standard.iso *)
1715 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1716 ((Some
((idb
, None
),[iidb
]), typb
, stob
, local), iivirg
) ->
1717 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1718 fullType typa typb
>>= (fun typa typb
->
1719 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1720 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1721 (fun stoa
(stob
, iistob
) ->
1723 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1724 (((Some
((idb
,None
),[iidb
]),typb
,stob
,local),iivirg
),
1728 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1729 ((Some
((idb
,Some inib
),[iidb
;iieqb
]),typb
,stob
,local),iivirg
)
1731 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1732 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1733 fullType typa typb
>>= (fun typa typb
->
1734 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1735 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1736 (fun stoa
(stob
, iistob
) ->
1737 initialiser inia inib
>>= (fun inia inib
->
1739 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1740 (((Some
((idb
,Some inib
),[iidb
;iieqb
]),typb
,stob
,local),iivirg
),
1744 (* do iso-by-absence here ? allow typedecl and var ? *)
1745 | A.TyDecl
(typa
, ptvirga
), ((None
, typb
, stob
, local), iivirg
) ->
1746 if stob
= (B.NoSto
, false)
1748 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1749 fullType typa typb
>>= (fun typa typb
->
1751 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1752 (((None
, typb
, stob
, local), iivirg
), iiptvirgb
, iistob
)
1757 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1758 ((Some
((idb
, None
),[iidb
]),typb
,(B.StoTypedef
,inline
),local),iivirg
) ->
1760 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1761 fullType typa typb
>>= (fun typa typb
->
1764 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
1765 return (stoa
, [iitypedef
])
1767 | _
-> failwith
"wierd, have both typedef and inline or nothing";
1768 ) >>= (fun stoa iistob
->
1769 (match A.unwrap ida
with
1770 | A.MetaType
(_
,_
,_
) ->
1773 Ast_c.nQ
, ((B.TypeName
(idb
, Ast_c.noTypedefDef
())), [iidb
])
1775 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
1776 match fake_typeb with
1777 | _nQ
, ((B.TypeName
(idb
,_typ
)), [iidb
]) ->
1778 return (ida
, (idb
, iidb
))
1779 | _
-> raise Impossible
1783 if (term sa
) =$
= idb
1785 tokenf sa iidb
>>= (fun sa iidb
->
1787 (A.TypeName sa
) +> A.rewrap ida
,
1791 | _
-> raise Impossible
1793 ) >>= (fun ida
(idb
, iidb
) ->
1795 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1796 (((Some
((idb
, None
),[iidb
]), typb
, (B.StoTypedef
,inline
),local),
1803 | _
, ((None
, typb
, sto
, _local
), _
) ->
1804 (* old: failwith "no variable in this declaration, wierd" *)
1809 | A.DisjDecl declas
, declb
->
1810 declas
+> List.fold_left
(fun acc decla
->
1812 (* (declaration (mckstart, allminus, decla) declb) *)
1813 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
1818 (* only in struct type decls *)
1819 | A.Ddots
(dots
,whencode
), _
->
1822 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
1823 failwith
"not handling Opt/Unique Decl"
1830 (* ------------------------------------------------------------------------- *)
1832 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
1833 X.all_bound
(A.get_inherited ia
) >&&>
1834 match (A.unwrap ia
,ib
) with
1836 | (A.InitExpr expa
, ib
) ->
1837 (match A.unwrap expa
, ib
with
1838 | A.Edots
(mcode, None
), ib
->
1839 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
1842 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
1847 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1849 | _
, (B.InitExpr expb
, ii
) ->
1851 expression expa expb
>>= (fun expa expb
->
1853 (A.InitExpr expa
) +> A.rewrap ia
,
1854 (B.InitExpr expb
, ii
)
1859 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
1861 | ib1::ib2
::iicommaopt
->
1862 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1863 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1864 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
1866 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
1867 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
1870 | _
-> raise Impossible
1873 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
1874 failwith
"TODO: not handling whencode in initialisers"
1877 | (A.InitGccDotName
(ia1
, ida
, ia2
, inia
),
1878 (B.InitDesignators
([B.DesignatorField idb
,ii1
], inib
), ii2
))->
1880 let (iidot
, iidb
) = tuple_of_list2 ii1
in
1881 let iieq = tuple_of_list1 ii2
in
1883 tokenf ia1 iidot
>>= (fun ia1 iidot
->
1884 tokenf ia2
iieq >>= (fun ia2
iieq ->
1885 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1886 initialiser inia inib
>>= (fun inia inib
->
1888 (A.InitGccDotName
(ia1
, ida
, ia2
, inia
)) +> A.rewrap ia
,
1890 ([B.DesignatorField idb
, [iidot
;iidb
]], inib
), [iieq])
1894 | (A.InitGccIndex
(ia1
,ea
,ia2
,ia3
,inia
),
1895 (B.InitDesignators
([B.DesignatorIndex eb
, ii1
], inib
), ii2
)) ->
1897 let (ib1, ib2
) = tuple_of_list2 ii1
in
1898 let ib3 = tuple_of_list1 ii2
in
1899 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1900 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1901 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
1902 expression ea eb
>>= (fun ea eb
->
1903 initialiser inia inib
>>= (fun inia inib
->
1905 (A.InitGccIndex
(ia1
,ea
,ia2
,ia3
,inia
)) +> A.rewrap ia
,
1907 ([B.DesignatorIndex eb
, [ib1;ib2
]], inib
), [ib3])
1911 | (A.InitGccRange
(ia1
,e1a
,ia2
,e2a
,ia3
,ia4
,inia
),
1912 (B.InitDesignators
([B.DesignatorRange
(e1b
, e2b
), ii1
], inib
), ii2
)) ->
1914 let (ib1, ib2
, ib3) = tuple_of_list3 ii1
in
1915 let (ib4
) = tuple_of_list1 ii2
in
1916 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1917 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1918 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
1919 tokenf ia4 ib4
>>= (fun ia4 ib4
->
1920 expression e1a e1b
>>= (fun e1a e1b
->
1921 expression e2a e2b
>>= (fun e2a e2b
->
1922 initialiser inia inib
>>= (fun inia inib
->
1924 (A.InitGccRange
(ia1
,e1a
,ia2
,e2a
,ia3
,ia4
,inia
)) +> A.rewrap ia
,
1926 ([B.DesignatorRange
(e1b
, e2b
),[ib1;ib2
;ib3]], inib
), [ib4
])
1932 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
1935 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
1936 initialiser inia inib
>>= (fun inia inib
->
1937 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
1939 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
1940 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
1947 | A.IComma
(comma
), _
->
1950 | A.UniqueIni _
,_
| A.OptIni _
,_
->
1951 failwith
"not handling Opt/Unique on initialisers"
1959 and initialisers
= fun ias
(ibs
, iicomma
) ->
1960 let ias_unsplit = unsplit_icomma ias
in
1961 let ibs_split = resplit_initialiser ibs iicomma
in
1964 if need_unordered_initialisers ibs
1965 then initialisers_unordered2
1966 else initialisers_ordered2
1968 f ias_unsplit ibs_split >>=
1969 (fun ias_unsplit ibs_split ->
1971 split_icomma ias_unsplit,
1972 unsplit_initialiser ibs_split
1976 (* todo: one day julia will reput a IDots *)
1977 and initialisers_ordered2
= fun ias ibs
->
1979 | [], [] -> return ([], [])
1980 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
1981 (match A.unwrap xcomma
with
1982 | A.IComma commax
->
1983 tokenf commax commay
>>= (fun commax commay
->
1984 initialiser x y
>>= (fun x y
->
1985 initialisers_ordered2 xs ys
>>= (fun xs ys
->
1987 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
1991 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
1997 and initialisers_unordered2
= fun ias ibs
->
2000 | [], ys
-> return ([], ys
)
2001 | (x
,xcomma
)::xs
, ys
->
2003 let permut = Common.uncons_permut_lazy ys
in
2004 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2007 (match A.unwrap xcomma
, e
with
2008 | A.IComma commax
, (y
, commay
) ->
2009 tokenf commax commay
>>= (fun commax commay
->
2010 initialiser x y
>>= (fun x y
->
2012 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2016 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2019 let rest = Lazy.force
rest in
2020 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2023 Common.insert_elem_pos
(e
, pos
) rest
2028 (* ------------------------------------------------------------------------- *)
2029 and (struct_fields
: (A.declaration list
, B.field
B.wrap list
) matcher
) =
2032 | [], [] -> return ([], [])
2033 | [], eb
::ebs
-> fail
2035 X.all_bound
(A.get_inherited ea
) >&&>
2036 (match A.unwrap ea
, ebs
with
2037 | A.Ddots
(mcode, optwhen
), ys
->
2038 if optwhen
<> None
then failwith
"not handling when in argument";
2040 (* '...' can take more or less the beginnings of the arguments *)
2041 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2042 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2047 if mcode_contain_plus (mcodekind mcode)
2049 (* failwith "I have no token that I could accroche myself on" *)
2050 else return (dots2metavar mcode, [])
2053 X.distrf_struct_fields
(dots2metavar mcode) startxs
2054 ) >>= (fun mcode startxs ->
2055 let mcode = metavar2dots mcode in
2056 struct_fields
eas endxs
>>= (fun eas endxs
->
2058 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2063 | _unwrapx
, eb
::ebs
->
2064 struct_field ea eb
>>= (fun ea eb
->
2065 struct_fields
eas ebs
>>= (fun eas ebs
->
2066 return (ea
::eas, eb
::ebs
)
2069 | _unwrapx
, [] -> fail
2072 and (struct_field
: (A.declaration
, B.field
B.wrap
) matcher
) = fun fa fb
->
2073 let (xfield
, ii
) = fb
in
2074 let iiptvirgb = tuple_of_list1 ii
in
2077 | B.FieldDeclList onefield_multivars
->
2079 (match onefield_multivars
with
2080 | [] -> raise Impossible
2081 | [onevar
,iivirg
] ->
2082 assert (null iivirg
);
2084 | B.BitField
(sopt
, typb
, expr
), ii
->
2085 pr2_once
"warning: bitfield not handled by ast_cocci";
2087 | B.Simple
(None
, typb
), ii
->
2088 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2090 | B.Simple
(Some idb
, typb
), ii
->
2091 let (iidb
) = tuple_of_list1 ii
in
2093 (* build a declaration from a struct field *)
2094 let allminus = false in
2096 let stob = B.NoSto
, false in
2098 ((Some
((idb
, None
),[iidb
]), typb
, stob, Ast_c.NotLocalDecl
),
2101 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2102 (fun fa
(var
,iiptvirgb,iisto) ->
2105 | ((Some
((idb
, None
),[iidb
]), typb
, stob, local), iivirg
) ->
2106 let onevar = B.Simple
(Some idb
, typb
), [iidb
] in
2110 (B.FieldDeclList
[onevar, iivirg
], [iiptvirgb])
2112 | _
-> raise Impossible
2117 pr2_once
"PB: More that one variable in decl. Have to split";
2120 | B.EmptyField
-> fail
2124 (* ------------------------------------------------------------------------- *)
2125 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2127 X.optional_qualifier_flag
(fun optional_qualifier
->
2128 X.all_bound
(A.get_inherited typa
) >&&>
2129 match A.unwrap typa
, typb
with
2130 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2132 if qu
.B.const
&& qu
.B.volatile
2135 ("warning: the type is both const & volatile but cocci " ^
2136 "does not handle that");
2138 (* Drop out the const/volatile part that has been matched.
2139 * This is because a SP can contain const T v; in which case
2140 * later in match_t_t when we encounter a T, we must not add in
2141 * the environment the whole type.
2146 (* "iso-by-absence" *)
2149 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2151 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2155 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2156 | false, false -> do_stuff ()
2157 | false, true -> fail
2158 | true, false -> do_stuff ()
2161 then pr2_once
"USING optional_qualifier builtin isomorphism";
2167 (* todo: can be __const__ ? can be const & volatile so
2168 * should filter instead ?
2170 (match term x
, il
with
2171 | A.Const
, [i1
] when qu
.B.const
->
2173 tokenf x i1
>>= (fun x i1
->
2174 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2176 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2180 | A.Volatile
, [i1
] when qu
.B.volatile
->
2181 tokenf x i1
>>= (fun x i1
->
2182 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2184 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2192 | A.DisjType typas
, typb
->
2194 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2196 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2197 -> failwith
"not handling Opt/Unique on type"
2202 * Why not (A.typeC, Ast_c.typeC) matcher ?
2203 * because when there is MetaType, we want that T record the whole type,
2204 * including the qualifier, and so this type (and the new_il function in
2205 * preceding function).
2208 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2210 X.all_bound
(A.get_inherited ta
) >&&>
2211 match A.unwrap ta
, tb
with
2214 | A.MetaType
(ida
,keep
, inherited
), typb
->
2216 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2217 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2218 X.distrf_type ida typb
>>= (fun ida typb
->
2220 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2224 | unwrap
, (qub
, typb
) ->
2225 typeC ta typb
>>= (fun ta typb
->
2226 return (ta
, (qub
, typb
))
2230 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2232 match A.unwrap ta
, tb
with
2233 | A.BaseType
(basea
, signaopt
), (B.BaseType baseb
, ii
) ->
2234 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2235 * And even if in baseb we have a Signed Int, that does not mean
2236 * that ii is of length 2, cos Signed is the default, so if in signa
2237 * we have Signed explicitely ? we cant "accrocher" this mcode to
2238 * something :( So for the moment when there is signed in cocci,
2239 * we force that there is a signed in c too (done in pattern.ml).
2241 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2244 (* handle some iso on type ? (cf complex C rule for possible implicit
2246 (match term basea
, baseb
with
2247 | A.VoidType
, B.Void
2248 | A.FloatType
, B.FloatType
(B.CFloat
)
2249 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2250 assert (signaopt
= None
);
2251 let (ibaseb
) = tuple_of_list1 ii
in
2252 tokenf basea ibaseb
>>= (fun basea ibaseb
->
2254 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2255 (B.BaseType baseb
, [ibaseb
])
2258 | A.CharType
, B.IntType
B.CChar
when signaopt
= None
->
2259 let ibaseb = tuple_of_list1 ii
in
2260 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2262 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2263 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2266 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2267 let ibaseb = tuple_of_list1 iibaseb
in
2268 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2269 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2271 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2272 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2275 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2276 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2277 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2280 (* iso-by-presence ? *)
2281 (* when unsigned int in SP, allow have just unsigned in C ? *)
2282 if mcode_contain_plus (mcodekind basea
)
2286 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2288 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2289 (B.BaseType
(baseb
), iisignbopt
++ [])
2295 "warning: long int or short int not handled by ast_cocci";
2299 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2300 tokenf basea
ibaseb >>= (fun basea
ibaseb ->
2302 (A.BaseType
(basea
, signaopt
)) +> A.rewrap ta
,
2303 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2305 | _
-> raise Impossible
2310 | _
, B.IntType
(B.Si
(_
, B.CLongLong
))
2311 | _
, B.FloatType
B.CLongDouble
2314 "warning: long long or long double not handled by ast_cocci";
2323 | A.ImplicitInt
(signa
), (B.BaseType baseb
, ii
) ->
2324 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2325 (match iibaseb
, baseb
with
2326 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2327 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2329 | None
-> raise Impossible
2332 (A.ImplicitInt
(signa
)) +> A.rewrap ta
,
2333 (B.BaseType baseb
, iisignbopt
)
2341 (* todo? iso with array *)
2342 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2343 let (ibmult
) = tuple_of_list1 ii
in
2344 fullType typa typb
>>= (fun typa typb
->
2345 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2347 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2348 (B.Pointer typb
, [ibmult
])
2351 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2352 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2354 let (lpb
, rpb
) = tuple_of_list2 ii
in
2358 ("Not handling well variable length arguments func. "^
2359 "You have been warned");
2360 tokenf lpa lpb
>>= (fun lpa lpb
->
2361 tokenf rpa rpb
>>= (fun rpa rpb
->
2362 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2363 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2364 (fun paramsaundots paramsb
->
2365 let paramsa = redots
paramsa paramsaundots
in
2367 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2368 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2376 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2377 (B.ParenType t1
, ii
) ->
2378 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2379 let (qu1b
, t1b
) = t1
in
2381 | B.Pointer t2
, ii
->
2382 let (starb
) = tuple_of_list1 ii
in
2383 let (qu2b
, t2b
) = t2
in
2385 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2386 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2391 ("Not handling well variable length arguments func. "^
2392 "You have been warned");
2394 fullType tya tyb
>>= (fun tya tyb
->
2395 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2396 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2397 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2398 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2399 tokenf stara starb
>>= (fun stara starb
->
2400 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2401 (fun paramsaundots paramsb
->
2402 let paramsa = redots
paramsa paramsaundots
in
2406 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2411 (B.Pointer
t2, [starb
]))
2415 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2417 (B.ParenType
t1, [lp1b
;rp1b
])
2430 (* todo: handle the iso on optionnal size specifification ? *)
2431 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2432 let (ib1, ib2
) = tuple_of_list2 ii
in
2433 fullType typa typb
>>= (fun typa typb
->
2434 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2435 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2436 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2438 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2439 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2443 (* todo: could also match a Struct that has provided a name *)
2444 (* This is for the case where the SmPL code contains "struct x", without
2445 a definition. In this case, the name field is always present.
2446 This case is also called from the case for A.StructUnionDef when
2447 a name is present in the C code. *)
2448 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2449 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2450 let (ib1, ib2
) = tuple_of_list2 ii
in
2451 if equal_structUnion (term sua
) sub
2453 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2454 tokenf sua
ib1 >>= (fun sua
ib1 ->
2456 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2457 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2462 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2463 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2465 let (ii_sub_sb
, lbb
, rbb
) =
2467 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2468 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2469 | _
-> failwith
"list of length 3 or 4 expected" in
2472 match (sbopt
,ii_sub_sb
) with
2473 (None
,Common.Left iisub
) ->
2474 (* the following doesn't reconstruct the complete SP code, just
2475 the part that matched *)
2477 match A.unwrap s
with
2479 (match A.unwrap ty
with
2480 A.StructUnionName
(sua
, None
) ->
2481 tokenf sua iisub
>>= (fun sua iisub
->
2484 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2486 return (ty,[iisub
]))
2488 | A.DisjType
(disjs
) ->
2490 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2494 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2496 (* build a StructUnionName from a StructUnion *)
2497 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2499 fullType
ty fake_su >>= (fun ty fake_su ->
2501 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2502 return (ty, [iisub
; iisb
])
2503 | _
-> raise Impossible
)
2507 >>= (fun ty ii_sub_sb
->
2509 tokenf lba lbb
>>= (fun lba lbb
->
2510 tokenf rba rbb
>>= (fun rba rbb
->
2511 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2512 let declsa = redots
declsa undeclsa
in
2515 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2516 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2520 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2521 * uint in the C code. But some CEs consists in renaming some types,
2522 * so we don't want apply isomorphisms every time.
2524 | A.TypeName sa
, (B.TypeName
(sb
,typb
), ii
) ->
2525 let (isb
) = tuple_of_list1 ii
in
2528 tokenf sa isb
>>= (fun sa isb
->
2530 (A.TypeName sa
) +> A.rewrap ta
,
2531 (B.TypeName
(sb
,typb
), [isb
])
2535 | _
, (B.TypeOfExpr e
, ii
) -> fail
2536 | _
, (B.TypeOfType e
, ii
) -> fail
2540 (* todo: iso on sign, if not mentioned then free. tochange?
2541 * but that require to know if signed int because explicit
2542 * signed int, or because implicit signed int.
2545 and sign signa signb
=
2546 match signa
, signb
with
2547 | None
, None
-> return (None
, [])
2548 | Some signa
, Some
(signb
, ib
) ->
2549 if equal_sign (term signa
) signb
2550 then tokenf signa ib
>>= (fun signa ib
->
2551 return (Some signa
, [ib
])
2557 and minusize_list iixs
=
2558 iixs
+> List.fold_left
(fun acc ii
->
2559 acc
>>= (fun xs ys
->
2560 tokenf minusizer ii
>>= (fun minus ii
->
2561 return (minus
::xs
, ii
::ys
)
2562 ))) (return ([],[]))
2563 >>= (fun _xsminys ys
->
2564 return ((), List.rev ys
)
2567 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
2568 (* "iso-by-absence" for storage, and return type. *)
2569 X.optional_storage_flag
(fun optional_storage
->
2570 match stoa
, stob with
2571 | None
, (stobis
, inline
) ->
2575 minusize_list iistob
>>= (fun () iistob
->
2576 return (None
, (stob, iistob
))
2578 else return (None
, (stob, iistob
))
2581 (match optional_storage
, stobis
with
2582 | false, B.NoSto
-> do_minus ()
2584 | true, B.NoSto
-> do_minus ()
2587 then pr2_once
"USING optional_storage builtin isomorphism";
2591 | Some x
, ((stobis
, inline
)) ->
2592 if equal_storage (term x
) stobis
2596 tokenf x i1
>>= (fun x i1
->
2597 return (Some x
, ((stobis
, inline
), [i1
]))
2599 (* or if have inline ? have to do a split_storage_inline a la
2600 * split_signb_baseb_ii *)
2601 | _
-> raise Impossible
2609 and fullType_optional_allminus
allminus tya retb
=
2614 X.distrf_type
minusizer retb
>>= (fun _x retb
->
2618 else return (None
, retb
)
2620 fullType tya retb
>>= (fun tya retb
->
2621 return (Some tya
, retb
)
2626 (*---------------------------------------------------------------------------*)
2627 and compatible_type a
(b
,_local
) =
2628 let ok = return ((),()) in
2630 let rec loop = function
2631 | Type_cocci.BaseType
(a
, signa
), (qua
, (B.BaseType b
,ii
)) ->
2633 | Type_cocci.VoidType
, B.Void
->
2634 assert (signa
= None
);
2636 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
= None
->
2638 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2639 compatible_sign signa signb
2640 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
2641 compatible_sign signa signb
2642 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
2643 compatible_sign signa signb
2644 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
2645 compatible_sign signa signb
2646 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
2647 pr2_once
"no longlong in cocci";
2649 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
2650 assert (signa
= None
);
2652 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
2653 assert (signa
= None
);
2655 | _
, B.FloatType
B.CLongDouble
->
2656 pr2_once
"no longdouble in cocci";
2658 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
2662 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
2664 | Type_cocci.FunctionPointer a
, _
->
2666 "TODO: function pointer type doesn't store enough information to determine compatability"
2667 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
2668 (* no size info for cocci *)
2670 | Type_cocci.StructUnionName
(sua
, _
, sa
),
2671 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
2672 if equal_structUnion_type_cocci sua sub
&& sa
= sb
2676 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(sb
,_typb
), ii
)) ->
2681 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
2682 if (fst qub
).B.const
&& (fst qub
).B.volatile
2685 pr2_once
("warning: the type is both const & volatile but cocci " ^
2686 "does not handle that");
2692 | Type_cocci.Const
-> (fst qub
).B.const
2693 | Type_cocci.Volatile
-> (fst qub
).B.volatile
2695 then loop (a
,(Ast_c.nQ
, b
))
2698 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
2700 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2701 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
2705 (* subtil: must be after the MetaType case *)
2706 | a
, (qub
, (B.TypeName
(sb
,Some b
), ii
)) ->
2707 (* kind of typedef iso *)
2714 (* for metavariables of type expression *^* *)
2715 | Type_cocci.Unknown
, _
-> ok
2720 and compatible_sign signa signb
=
2721 let ok = return ((),()) in
2722 match signa
, signb
with
2724 | Some
Type_cocci.Signed
, B.Signed
2725 | Some
Type_cocci.Unsigned
, B.UnSigned
2730 and equal_structUnion_type_cocci a b
=
2732 | Type_cocci.Struct
, B.Struct
-> true
2733 | Type_cocci.Union
, B.Union
-> true
2738 (*---------------------------------------------------------------------------*)
2739 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
2741 let rec aux_inc (ass
, bss
) passed
=
2745 let passed = List.rev
passed in
2747 (match before_after
, !h_rel_pos
with
2748 | IncludeNothing
, _
-> true
2749 | IncludeMcodeBefore
, Some x
->
2750 List.mem
passed (x
.Ast_c.first_of
)
2752 | IncludeMcodeAfter
, Some x
->
2753 List.mem
passed (x
.Ast_c.last_of
)
2755 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
2759 | (A.IncPath x
)::xs
, y
::ys
-> x
= y
&& aux_inc (xs
, ys
) (x
::passed)
2760 | _
-> failwith
"IncDots not in last place or other pb"
2765 | A.Local ass
, B.Local bss
->
2766 aux_inc (ass
, bss
) []
2767 | A.NonLocal ass
, B.NonLocal bss
->
2768 aux_inc (ass
, bss
) []
2773 (*---------------------------------------------------------------------------*)
2775 and (define_params
: sequence
->
2776 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
2777 fun seqstyle eas ebs
->
2779 | Unordered
-> failwith
"not handling ooo"
2781 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
2782 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
2785 (* todo? facto code with argument and parameters ? *)
2786 and define_paramsbis
= fun eas ebs
->
2788 | [], [] -> return ([], [])
2789 | [], eb
::ebs
-> fail
2791 X.all_bound
(A.get_inherited ea
) >&&>
2792 (match A.unwrap ea
, ebs
with
2793 | A.DPdots
(mcode), ys
->
2795 (* '...' can take more or less the beginnings of the arguments *)
2796 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2797 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2802 if mcode_contain_plus (mcodekind mcode)
2804 (* failwith "I have no token that I could accroche myself on" *)
2805 else return (dots2metavar mcode, [])
2807 (match Common.last
startxs with
2810 X.distrf_define_params
(dots2metavar mcode) startxs
2812 ) >>= (fun mcode startxs ->
2813 let mcode = metavar2dots mcode in
2814 define_paramsbis
eas endxs
>>= (fun eas endxs
->
2816 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
2822 | A.DPComma ia1
, Right ii
::ebs
->
2823 let ib1 = tuple_of_list1 ii
in
2824 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2825 define_paramsbis
eas ebs
>>= (fun eas ebs
->
2827 (A.DPComma ia1
+> A.rewrap ea
)::eas,
2832 | A.DPComma ia1
, ebs
->
2833 if mcode_contain_plus (mcodekind ia1
)
2836 (define_paramsbis
eas ebs
) (* try optional comma trick *)
2838 | (A.OptDParam _
| A.UniqueDParam _
), _
->
2839 failwith
"handling Opt/Unique for define parameters"
2841 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
2843 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
2844 let ib1 = tuple_of_list1 ii
in
2845 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
2846 define_paramsbis
eas ebs
>>= (fun eas ebs
->
2848 (A.DParam ida
)+> A.rewrap ea
:: eas,
2849 (Left
(idb
, [ib1]))::ebs
2852 | _unwrapx
, (Right y
)::ys
-> raise Impossible
2853 | _unwrapx
, [] -> fail
2858 (*****************************************************************************)
2860 (*****************************************************************************)
2862 (* no global solution for positions here, because for a statement metavariable
2863 we want a MetaStmtVal, and for the others, it's not clear what we want *)
2865 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
2868 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
2870 X.all_bound
(A.get_inherited re
) >&&>
2873 match A.unwrap re
, F.unwrap node
with
2875 (* note: the order of the clauses is important. *)
2877 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
2879 (* the metaRuleElem contains just '-' information. We dont need to add
2880 * stuff in the environment. If we need stuff in environment, because
2881 * there is a + S somewhere, then this will be done via MetaStmt, not
2883 * Can match TrueNode/FalseNode/... so must be placed before those cases.
2886 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
2887 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
2888 (match unwrap_node
with
2890 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
2892 if X.mode
= PatternMode
2895 if mcode_contain_plus (mcodekind mcode)
2896 then failwith
"try add stuff on fake node"
2897 (* minusize or contextize a fake node is ok *)
2900 | F.EndStatement None
->
2901 if X.mode
= PatternMode
then return default
2903 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
2904 if mcode_contain_plus (mcodekind mcode)
2906 let fake_info = Ast_c.fakeInfo() in
2907 distrf distrf_node (mcodekind mcode)
2908 (F.EndStatement (Some fake_info))
2909 else return unwrap_node
2913 | F.EndStatement
(Some i1
) ->
2914 tokenf mcode i1
>>= (fun mcode i1
->
2916 A.MetaRuleElem
(mcode,keep
, inherited
),
2917 F.EndStatement
(Some i1
)
2921 if X.mode
= PatternMode
then return default
2922 else failwith
"a MetaRuleElem can't transform a headfunc"
2924 if X.mode
= PatternMode
then return default
2926 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
2928 A.MetaRuleElem
(mcode,keep
, inherited
),
2934 (* rene cant have found that a state containing a fake/exit/... should be
2936 * TODO: and F.Fake ?
2938 | _
, F.EndStatement _
| _
, F.CaseNode _
2939 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
| _
, F.FallThroughNode
2943 (* really ? diff between pattern.ml and transformation.ml *)
2944 | _
, F.Fake
-> fail2()
2947 (* cas general: a Meta can match everything. It matches only
2948 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
2949 * So can't have been called in transform.
2951 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
2953 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
2954 (* todo: should not happen in transform mode *)
2956 (match Control_flow_c.extract_fullstatement node
with
2959 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
2960 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
2962 (* no need tag ida, we can't be called in transform-mode *)
2964 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
2972 | A.MetaStmtList _
, _
->
2973 failwith
"not handling MetaStmtList"
2975 | A.TopExp ea
, F.DefineExpr eb
->
2976 expression ea eb
>>= (fun ea eb
->
2982 | A.TopExp ea
, F.DefineType eb
->
2983 (match A.unwrap ea
with
2985 fullType ft eb
>>= (fun ft eb
->
2987 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
2994 (* It is important to put this case before the one that fails because
2995 * of the lack of the counter part of a C construct in SmPL (for instance
2996 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
2997 * yet certain constructs, those constructs may contain expression
2998 * that we still want and can transform.
3001 | A.Exp exp
, nodeb
->
3003 (* kind of iso, initialisation vs affectation *)
3005 match A.unwrap exp
, nodeb
with
3006 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3007 initialisation_to_affectation decl
+> F.rewrap node
3012 (* Now keep fullstatement inside the control flow node,
3013 * so that can then get in a MetaStmtVar the fullstatement to later
3014 * pp back when the S is in a +. But that means that
3015 * Exp will match an Ifnode even if there is no such exp
3016 * inside the condition of the Ifnode (because the exp may
3017 * be deeper, in the then branch). So have to not visit
3018 * all inside a node anymore.
3020 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3021 * fois le fullstatement et le partialstatement et appeler le
3022 * visiteur que sur le partialstatement.
3025 match Ast_cocci.get_pos re
with
3026 | None
-> expression
3030 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3031 let keep = Type_cocci.Unitary
in
3032 let inherited = false in
3033 let max_min _
= failwith
"no pos" in
3034 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3040 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3048 X.cocciTy fullType
ty node >>= (fun ty node ->
3055 | A.TopInit init
, nodeb
->
3056 X.cocciInit initialiser init
node >>= (fun init
node ->
3064 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3065 F.FunHeader
((idb
, (retb
, (paramsb
, (isvaargs
, iidotsb
))), stob), ii
) ->
3067 (* fninfoa records the order in which the SP specified the various
3068 information, but this isn't taken into account in the matching.
3069 Could this be a problem for transformation? *)
3072 List.filter
(function A.FStorage
(s
) -> true | _
-> false) fninfoa
3073 with [A.FStorage
(s
)] -> Some s
| _
-> None
in
3075 match List.filter
(function A.FType
(s
) -> true | _
-> false) fninfoa
3076 with [A.FType
(t
)] -> Some t
| _
-> None
in
3078 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3079 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3081 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3082 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3085 | iidb
::ioparenb
::icparenb
::iifakestart
::iistob
->
3087 (* maybe important to put ident as the first tokens to transform.
3088 * It's related to transform_proto. So don't change order
3091 ident LocalFunction ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3092 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3093 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3094 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3095 parameters
(seqstyle paramsa)
3096 (A.undots
paramsa) paramsb
>>=
3097 (fun paramsaundots paramsb
->
3098 let paramsa = redots
paramsa paramsaundots
in
3099 storage_optional_allminus
allminus
3100 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3105 ("Not handling well variable length arguments func. "^
3106 "You have been warned");
3108 then minusize_list iidotsb
3109 else return ((),iidotsb
)
3110 ) >>= (fun () iidotsb
->
3112 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3115 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3116 (match tya with Some t
-> [A.FType t
] | None
-> [])
3121 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3123 F.FunHeader
((idb
, (retb
, (paramsb
, (isvaargs
, iidotsb
))),
3125 iidb
::ioparenb
::icparenb
::iifakestart
::iistob
)
3128 | _
-> raise Impossible
3136 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3137 declaration
(mckstart
,allminus,decla
) declb
>>=
3138 (fun (mckstart
,allminus,decla
) declb
->
3140 A.Decl
(mckstart
,allminus,decla
),
3145 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3146 tokenf mcode i1
>>= (fun mcode i1
->
3149 F.SeqStart
(st
, level
, i1
)
3152 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3153 tokenf mcode i1
>>= (fun mcode i1
->
3156 F.SeqEnd
(level
, i1
)
3159 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3160 let ib1 = tuple_of_list1 ii
in
3161 expression ea eb
>>= (fun ea eb
->
3162 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3164 A.ExprStatement
(ea
, ia1
),
3165 F.ExprStatement
(st
, (Some eb
, [ib1]))
3170 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3171 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3172 expression ea eb
>>= (fun ea eb
->
3173 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3174 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3175 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3177 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3178 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3181 | A.Else ia
, F.Else ib
->
3182 tokenf ia ib
>>= (fun ia ib
->
3183 return (A.Else ia
, F.Else ib
)
3186 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3187 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3188 expression ea eb
>>= (fun ea eb
->
3189 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3190 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3191 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3193 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3194 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3]))
3197 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3198 tokenf ia ib
>>= (fun ia ib
->
3203 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3204 let (ib1, ib2
, ib3, ib4
) = tuple_of_list4 ii
in
3205 expression ea eb
>>= (fun ea eb
->
3206 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3207 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3208 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3209 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3211 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3212 F.DoWhileTail
(eb
, [ib1;ib2
;ib3;ib4
])
3214 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s
,ebs
),ii
))
3216 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3218 ident DontKnow ia1
(s
, ib1) >>= (fun ia1
(s
, ib1) ->
3219 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3220 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3221 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3222 let eas = redots
eas easundots
in
3224 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3225 F.MacroIterHeader
(st
, ((s
,ebs
), [ib1;ib2
;ib3]))
3230 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3231 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3233 assert (null ib4vide
);
3234 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3235 let ib3 = tuple_of_list1 ib3s
in
3236 let ib4 = tuple_of_list1 ib4s
in
3238 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3239 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3240 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3241 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3242 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3243 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3244 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3245 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3247 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3248 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3254 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3255 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3256 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3257 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3258 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3259 expression ea eb
>>= (fun ea eb
->
3261 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3262 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3265 | A.Break
(ia1
, ia2
), F.Break
(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
->
3271 F.Break
(st
, ((),[ib1;ib2
]))
3274 | A.Continue
(ia1
, ia2
), F.Continue
(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.Continue
(ia1
, ia2
),
3280 F.Continue
(st
, ((),[ib1;ib2
]))
3283 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3284 let (ib1, ib2
) = tuple_of_list2 ii
in
3285 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3286 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3288 A.Return
(ia1
, ia2
),
3289 F.Return
(st
, ((),[ib1;ib2
]))
3292 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3293 let (ib1, ib2
) = tuple_of_list2 ii
in
3294 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3295 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3296 expression ea eb
>>= (fun ea eb
->
3298 A.ReturnExpr
(ia1
, ea
, ia2
),
3299 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3304 | A.Include
(incla
,filea
), F.Include
((fileb
, ii
), (h_rel_pos
, inifdef
)) ->
3306 let include_requirment =
3307 match mcodekind incla
, mcodekind filea
with
3308 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3310 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3316 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3317 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3319 tokenf incla inclb
>>= (fun incla inclb
->
3320 tokenf filea iifileb
>>= (fun filea iifileb
->
3322 A.Include
(incla
, filea
),
3323 F.Include
((fileb
, [inclb
;iifileb
]), (h_rel_pos
, inifdef
))
3329 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3330 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3331 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3332 tokenf definea defineb
>>= (fun definea defineb
->
3333 (match A.unwrap params
, defkind
with
3334 | A.NoParams
, B.DefineVar
->
3336 A.NoParams
+> A.rewrap params
,
3339 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3340 let (lpb
, rpb
) = tuple_of_list2 ii
in
3341 tokenf lpa lpb
>>= (fun lpa lpb
->
3342 tokenf rpa rpb
>>= (fun rpa rpb
->
3344 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3345 (fun easundots ebs
->
3346 let eas = redots
eas easundots
in
3348 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3349 B.DefineFunc
(ebs
,[lpb
;rpb
])
3353 ) >>= (fun params defkind
->
3355 A.DefineHeader
(definea
, ida
, params
),
3356 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3361 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3362 let (ib1, ib2
) = tuple_of_list2 ii
in
3363 tokenf def
ib1 >>= (fun def
ib1 ->
3364 tokenf colon ib2
>>= (fun colon ib2
->
3366 A.Default
(def
,colon
),
3367 F.Default
(st
, ((),[ib1;ib2
]))
3372 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3373 let (ib1, ib2
) = tuple_of_list2 ii
in
3374 tokenf case
ib1 >>= (fun case
ib1 ->
3375 expression ea eb
>>= (fun ea eb
->
3376 tokenf colon ib2
>>= (fun colon ib2
->
3378 A.Case
(case
,ea
,colon
),
3379 F.Case
(st
, (eb
,[ib1;ib2
]))
3382 (* only occurs in the predicates generated by asttomember *)
3383 | A.DisjRuleElem
eas, _
->
3385 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3386 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3388 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3390 | A.Label
(id,dd
), F.Label
(st
,(s
,ii
)) ->
3391 let (ib1,ib2
) = tuple_of_list2 ii
in
3392 let (string_of_id
,rebuild
) =
3393 match A.unwrap
id with
3394 A.Id
(s
) -> (s
,function s
-> A.rewrap id (A.Id
(s
)))
3395 | _
-> failwith
"labels with metavariables not supported" in
3396 if (term string_of_id
) =$
= s
3398 tokenf string_of_id
ib1 >>= (fun string_of_id
ib1 ->
3399 tokenf dd ib2
>>= (fun dd ib2
->
3401 A.Label
(rebuild string_of_id
,dd
),
3402 F.Label
(st
,(s
,[ib1;ib2
]))
3406 | A.Goto
(goto
,id,sem
), F.Goto
(st
,(s
,ii
)) ->
3407 let (ib1,ib2
,ib3) = tuple_of_list3 ii
in
3408 tokenf goto
ib1 >>= (fun goto
ib1 ->
3409 ident DontKnow
id (s
, ib2
) >>= (fun id (s
, ib2
) ->
3410 tokenf sem
ib3 >>= (fun sem
ib3 ->
3412 A.Goto
(goto
,id,sem
),
3413 F.Goto
(st
,(s
,[ib1;ib2
;ib3]))
3416 (* have not a counter part in coccinelle, for the moment *)
3417 (* todo?: print a warning at least ? *)