2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
26 module F
= Control_flow_c
28 module Flag
= Flag_matcher
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
)
127 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
128 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
)
132 (s1
, i
, new_mck, pos
)
136 (*---------------------------------------------------------------------------*)
138 (* 0x0 is equivalent to 0, value format isomorphism *)
139 let equal_c_int s1 s2
=
141 int_of_string s1
=|= int_of_string s2
142 with Failure
("int_of_string") ->
147 (*---------------------------------------------------------------------------*)
148 (* Normally A should reuse some types of Ast_c, so those
149 * functions should not exist.
151 * update: but now Ast_c depends on A, so can't make too
152 * A depends on Ast_c, so have to stay with those equal_xxx
156 let equal_unaryOp a b
=
158 | A.GetRef
, B.GetRef
-> true
159 | A.DeRef
, B.DeRef
-> true
160 | A.UnPlus
, B.UnPlus
-> true
161 | A.UnMinus
, B.UnMinus
-> true
162 | A.Tilde
, B.Tilde
-> true
163 | A.Not
, B.Not
-> true
164 | _
, B.GetRefLabel
-> false (* todo cocci? *)
165 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
169 let equal_arithOp a b
=
171 | A.Plus
, B.Plus
-> true
172 | A.Minus
, B.Minus
-> true
173 | A.Mul
, B.Mul
-> true
174 | A.Div
, B.Div
-> true
175 | A.Mod
, B.Mod
-> true
176 | A.DecLeft
, B.DecLeft
-> true
177 | A.DecRight
, B.DecRight
-> true
178 | A.And
, B.And
-> true
179 | A.Or
, B.Or
-> true
180 | A.Xor
, B.Xor
-> true
181 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
184 let equal_logicalOp a b
=
186 | A.Inf
, B.Inf
-> true
187 | A.Sup
, B.Sup
-> true
188 | A.InfEq
, B.InfEq
-> true
189 | A.SupEq
, B.SupEq
-> true
190 | A.Eq
, B.Eq
-> true
191 | A.NotEq
, B.NotEq
-> true
192 | A.AndLog
, B.AndLog
-> true
193 | A.OrLog
, B.OrLog
-> true
194 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
197 let equal_assignOp a b
=
199 | A.SimpleAssign
, B.SimpleAssign
-> true
200 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
201 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
203 let equal_fixOp a b
=
205 | A.Dec
, B.Dec
-> true
206 | A.Inc
, B.Inc
-> true
207 | _
, (B.Inc
|B.Dec
) -> false
209 let equal_binaryOp a b
=
211 | A.Arith a
, B.Arith b
-> equal_arithOp a b
212 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
213 | _
, (B.Logical _
| B.Arith _
) -> false
215 let equal_structUnion a b
=
217 | A.Struct
, B.Struct
-> true
218 | A.Union
, B.Union
-> true
219 | _
, (B.Struct
|B.Union
) -> false
223 | A.Signed
, B.Signed
-> true
224 | A.Unsigned
, B.UnSigned
-> true
225 | _
, (B.UnSigned
|B.Signed
) -> false
227 let equal_storage a b
=
229 | A.Static
, B.Sto
B.Static
230 | A.Auto
, B.Sto
B.Auto
231 | A.Register
, B.Sto
B.Register
232 | A.Extern
, B.Sto
B.Extern
234 | _
, (B.NoSto
| B.StoTypedef
) -> false
235 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
238 (*---------------------------------------------------------------------------*)
240 let equal_metavarval valu valu'
=
241 match valu
, valu'
with
242 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
243 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
244 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
245 (* do something more ? *)
248 (* al_expr before comparing !!! and accept when they match.
249 * Note that here we have Astc._expression, so it is a match
250 * modulo isomorphism (there is no metavariable involved here,
251 * just isomorphisms). => TODO call isomorphism_c_c instead of
252 * =*=. Maybe would be easier to transform ast_c in ast_cocci
253 * and call the iso engine of julia. *)
254 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
255 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
256 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
257 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
259 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
260 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
261 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
262 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
263 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
264 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
267 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
269 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
270 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
271 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
272 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
274 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
275 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
277 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
279 (function (fla
,cea
,posa1
,posa2
) ->
281 (function (flb
,ceb
,posb1
,posb2
) ->
282 fla
=$
= flb
&& cea
=$
= ceb
&&
283 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
287 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
288 |B.MetaTypeVal _
|B.MetaInitVal _
289 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
290 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
295 (*---------------------------------------------------------------------------*)
296 (* could put in ast_c.ml, next to the split/unsplit_comma *)
297 let split_signb_baseb_ii (baseb
, ii
) =
298 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
299 match baseb
, iis with
301 | B.Void
, ["void",i1
] -> None
, [i1
]
303 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
304 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
305 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
307 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
310 | B.IntType
(B.Si
(sign
, base
)), xs
->
314 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
315 | (B.Signed
,rest
) -> (None
,rest
)
316 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
317 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
318 (* The original code only allowed explicit signed and unsigned for char,
319 while this code allows char by itself. Not sure that needs to be
320 checked for here. If it does, then add a special case. *)
322 match (base
,rest
) with
323 B.CInt
, ["int",i1
] -> [i1
]
326 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
327 (match i1
.B.pinfo
with
329 | _
-> failwith
("unrecognized signed int: "^
330 (String.concat
" "(List.map fst
iis))))
332 | B.CChar2
, ["char",i2
] -> [i2
]
334 | B.CShort
, ["short",i1
] -> [i1
]
335 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
337 | B.CLong
, ["long",i1
] -> [i1
]
338 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
340 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
341 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
344 failwith
("strange type1, maybe because of weird order: "^
345 (String.concat
" " (List.map fst
iis))) in
347 | _
-> failwith
("strange type2, maybe because of weird order: "^
348 (String.concat
" " (List.map fst
iis)))
350 (*---------------------------------------------------------------------------*)
352 let rec unsplit_icomma xs
=
356 (match A.unwrap y
with
358 (x
, y
)::unsplit_icomma xs
359 | _
-> failwith
"wrong ast_cocci in initializer"
362 failwith
("wrong ast_cocci in initializer, should have pair " ^
367 let resplit_initialiser ibs iicomma
=
368 match iicomma
, ibs
with
371 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
373 failwith
"shouldn't have a iicomma"
374 | [iicomma
], x
::xs
->
375 let elems = List.map fst
(x
::xs
) in
376 let commas = List.map snd
(x
::xs
) +> List.flatten
in
377 let commas = commas @ [iicomma
] in
379 | _
-> raise Impossible
383 let rec split_icomma xs
=
386 | (x
,y
)::xs
-> x
::y
::split_icomma xs
388 let rec unsplit_initialiser ibs_unsplit
=
389 match ibs_unsplit
with
390 | [] -> [], [] (* empty iicomma *)
392 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
393 (x
, [])::xs
, lastcomma
395 and unsplit_initialiser_bis comma_before
= function
396 | [] -> [], [comma_before
]
398 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
399 (x
, [comma_before
])::xs
, lastcomma
404 (*---------------------------------------------------------------------------*)
405 (* coupling: same in type_annotater_c.ml *)
406 let structdef_to_struct_name ty
=
408 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
410 | Some s
, [i1
;i2
;i3
;i4
] ->
411 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
415 | x
-> raise Impossible
417 | _
-> raise Impossible
419 (*---------------------------------------------------------------------------*)
420 let initialisation_to_affectation decl
=
422 | B.MacroDecl _
-> F.Decl decl
423 | B.DeclList
(xs
, iis) ->
425 (* todo?: should not do that if the variable is an array cos
426 * will have x[] = , mais de toute facon ca sera pas un InitExp
429 | [] -> raise Impossible
431 let ({B.v_namei
= var
;
432 B.v_type
= returnType
;
433 B.v_storage
= storage
;
438 | Some
(name
, iniopt
) ->
440 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
441 let iis = Ast_c.info_of_name name
in
444 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
445 | Ast_c.LocalDecl
-> Ast_c.LocalVar
(iis.Ast_c.pinfo
) in
448 ref (Some
((Lib_parsing_c.al_type returnType
),local),
451 let idexpr = (B.Ident
(ident), typ),Ast_c.noii
in
453 ((B.Assignment
(idexpr, B.SimpleAssign
, e
),
454 Ast_c.noType
()), [iini
])
460 pr2_once
"TODO: initialisation_to_affectation for multi vars";
461 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
462 * the Sequence expression operator of C and make an
463 * ExprStatement from that.
472 (*****************************************************************************)
473 (* Functor parameter combinators *)
474 (*****************************************************************************)
476 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
478 * version0: was not tagging the SP, so just tag the C
480 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
481 * val return : 'b -> tin -> 'b tout
482 * val fail : tin -> 'b tout
484 * version1: now also tag the SP so return a ('a * 'b)
487 type mode
= PatternMode
| TransformMode
495 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
500 (tin
-> ('a
* 'b
) tout
) ->
501 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
502 (tin
-> ('c
* 'd
) tout
)
504 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
505 val fail
: tin
-> ('a
* 'b
) tout
517 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
519 val tokenf
: ('a
A.mcode
, B.info
) matcher
520 val tokenf_mck
: (A.mcodekind, B.info
) matcher
523 (A.meta_name
A.mcode
, B.expression
) matcher
525 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
527 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
529 (A.meta_name
A.mcode
,
530 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
532 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
534 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
536 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
538 val distrf_define_params
:
539 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
542 val distrf_struct_fields
:
543 (A.meta_name
A.mcode
, B.field list
) matcher
546 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
549 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
552 (A.expression
, B.expression
) matcher
->
553 (A.expression
, B.expression
) matcher
556 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
559 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
562 A.keep_binding
-> A.inherited
->
563 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
564 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
565 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
567 val check_constraints
:
568 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
569 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
571 val all_bound
: A.meta_name list
-> (tin
-> bool)
573 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
574 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
575 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
580 (*****************************************************************************)
581 (* Functor code, "Cocci vs C" *)
582 (*****************************************************************************)
585 functor (X
: PARAM
) ->
588 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
591 let return = X.return
594 let (>||>) = X.(>||>)
595 let (>|+|>) = X.(>|+|>)
596 let (>&&>) = X.(>&&>)
598 let tokenf = X.tokenf
600 (* should be raise Impossible when called from transformation.ml *)
603 | PatternMode
-> fail
604 | TransformMode
-> raise Impossible
607 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
609 | (Some t1
, Some t2
) ->
610 f t1 t2
>>= (fun t1 t2
->
611 return (Some t1
, Some t2
)
613 | (None
, None
) -> return (None
, None
)
616 (* Dots are sometimes used as metavariables, since like metavariables they
617 can match other things. But they no longer have the same type. Perhaps these
618 functions could be avoided by introducing an appropriate level of polymorphism,
619 but I don't know how to declare polymorphism across functors *)
620 let dots2metavar (_
,info
,mcodekind,pos
) = (("","..."),info
,mcodekind,pos
)
621 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
623 (*---------------------------------------------------------------------------*)
635 (*---------------------------------------------------------------------------*)
636 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
638 X.all_bound
(A.get_inherited ea
) >&&>
639 let wa x
= A.rewrap ea x
in
640 match A.unwrap ea
, eb
with
642 (* general case: a MetaExpr can match everything *)
643 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
644 (((expr
, opttypb
), ii
) as expb
) ->
646 (* old: before have a MetaConst. Now we factorize and use 'form' to
647 * differentiate between different cases *)
648 let rec matches_id = function
649 B.Ident
(name
) -> true
650 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
653 match (form
,expr
) with
656 let rec matches = function
657 B.Constant
(c
) -> true
658 | B.Ident
(nameidb
) ->
659 let s = Ast_c.str_of_name nameidb
in
660 if s =~
"^[A-Z_][A-Z_0-9]*$"
662 pr2_once
("warning: I consider " ^
s ^
" as a constant");
666 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
667 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
668 | B.SizeOfExpr
(exp
) -> true
669 | B.SizeOfType
(ty
) -> true
675 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
677 | (A.ID
,e
) -> matches_id e
in
681 (let (opttypb
,_testb
) = !opttypb
in
682 match opttypa
, opttypb
with
683 | None
, _
-> return ((),())
685 pr2_once
("Missing type information. Certainly a pb in " ^
686 "annotate_typer.ml");
689 | Some tas
, Some tb
->
690 tas
+> List.fold_left
(fun acc ta
->
691 acc
>|+|> compatible_type ta tb
) fail
694 X.check_constraints expression constraints eb
697 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
698 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
700 X.distrf_e ida expb
>>= (fun ida expb
->
702 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
710 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
711 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
713 * but bug! because if have not tagged SP, then transform without doing
714 * any checks. Hopefully now have tagged SP technique.
719 * | A.Edots _, _ -> raise Impossible.
721 * In fact now can also have the Edots inside normal expression, not
722 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
724 | A.Edots
(mcode
, None
), expb
->
725 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
727 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
732 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
735 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
737 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
739 ((A.Ident ida
)) +> wa,
740 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
746 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
748 (* todo?: handle some isomorphisms in int/float ? can have different
749 * format : 1l can match a 1.
751 * todo: normally string can contain some metavar too, so should
752 * recurse on the string
754 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
755 (* for everything except the String case where can have multi elems *)
757 let ib1 = tuple_of_list1 ii
in
758 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
760 ((A.Constant ia1
)) +> wa,
761 ((B.Constant
(ib
), typ),[ib1])
764 (match term ia1
, ib
with
765 | A.Int x
, B.Int y
->
766 X.value_format_flag
(fun use_value_equivalence
->
767 if use_value_equivalence
777 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
779 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
782 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
785 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
787 ((A.Constant ia1
)) +> wa,
788 ((B.Constant
(ib
), typ),[ib1])
790 | _
-> fail (* multi string, not handled *)
793 | _
, B.MultiString _
-> (* todo cocci? *) fail
794 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
798 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
799 (* todo: do special case to allow IdMetaFunc, cos doing the
800 * recursive call will be too late, match_ident will not have the
801 * info whether it was a function. todo: but how detect when do
802 * x.field = f; how know that f is a Func ? By having computed
803 * some information before the matching!
805 * Allow match with FunCall containing types. Now ast_cocci allow
806 * type in parameter, and morover ast_cocci allow f(...) and those
807 * ... could match type.
809 let (ib1, ib2
) = tuple_of_list2 ii
in
810 expression ea eb
>>= (fun ea eb
->
811 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
812 tokenf ia2 ib2
>>= (fun ia2 ib2
->
813 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
814 let eas = redots
eas easundots
in
816 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
817 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
823 | A.Assignment
(ea1
, opa
, ea2
, simple
),
824 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
825 let (opbi
) = tuple_of_list1 ii
in
826 if equal_assignOp (term opa
) opb
828 expression ea1 eb1
>>= (fun ea1 eb1
->
829 expression ea2 eb2
>>= (fun ea2 eb2
->
830 tokenf opa opbi
>>= (fun opa opbi
->
832 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
833 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
837 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
838 let (ib1, ib2
) = tuple_of_list2 ii
in
839 expression ea1 eb1
>>= (fun ea1 eb1
->
840 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
841 expression ea3 eb3
>>= (fun ea3 eb3
->
842 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
843 tokenf ia2 ib2
>>= (fun ia2 ib2
->
845 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
846 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
849 (* todo?: handle some isomorphisms here ? *)
850 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
851 let opbi = tuple_of_list1 ii
in
852 if equal_fixOp (term opa
) opb
854 expression ea eb
>>= (fun ea eb
->
855 tokenf opa
opbi >>= (fun opa
opbi ->
857 ((A.Postfix
(ea
, opa
))) +> wa,
858 ((B.Postfix
(eb
, opb
), typ),[opbi])
863 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
864 let opbi = tuple_of_list1 ii
in
865 if equal_fixOp (term opa
) opb
867 expression ea eb
>>= (fun ea eb
->
868 tokenf opa
opbi >>= (fun opa
opbi ->
870 ((A.Infix
(ea
, opa
))) +> wa,
871 ((B.Infix
(eb
, opb
), typ),[opbi])
875 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
876 let opbi = tuple_of_list1 ii
in
877 if equal_unaryOp (term opa
) opb
879 expression ea eb
>>= (fun ea eb
->
880 tokenf opa
opbi >>= (fun opa
opbi ->
882 ((A.Unary
(ea
, opa
))) +> wa,
883 ((B.Unary
(eb
, opb
), typ),[opbi])
887 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
888 let opbi = tuple_of_list1 ii
in
889 if equal_binaryOp (term opa
) opb
891 expression ea1 eb1
>>= (fun ea1 eb1
->
892 expression ea2 eb2
>>= (fun ea2 eb2
->
893 tokenf opa
opbi >>= (fun opa
opbi ->
895 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
896 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
900 | A.Nested
(ea1
, opa
, ea2
), eb
->
902 (if A.get_test_exp ea1
&& not
(Ast_c.is_test eb
) then fail
903 else expression ea1 eb
) >|+|>
905 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
906 when equal_binaryOp (term opa
) opb
->
907 let opbi = tuple_of_list1 ii
in
909 (expression ea1 eb1
>>= (fun ea1 eb1
->
910 expression ea2 eb2
>>= (fun ea2 eb2
->
911 tokenf opa
opbi >>= (fun opa
opbi ->
913 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
914 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
917 (expression ea2 eb1
>>= (fun ea2 eb1
->
918 expression ea1 eb2
>>= (fun ea1 eb2
->
919 tokenf opa
opbi >>= (fun opa
opbi ->
921 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
922 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
925 (loop eb1
>>= (fun ea1 eb1
->
926 expression ea2 eb2
>>= (fun ea2 eb2
->
927 tokenf opa
opbi >>= (fun opa
opbi ->
929 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
930 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
933 (expression ea2 eb1
>>= (fun ea2 eb1
->
934 loop eb2
>>= (fun ea1 eb2
->
935 tokenf opa
opbi >>= (fun opa
opbi ->
937 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
938 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
940 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
944 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
945 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
946 let (ib1, ib2
) = tuple_of_list2 ii
in
947 expression ea1 eb1
>>= (fun ea1 eb1
->
948 expression ea2 eb2
>>= (fun ea2 eb2
->
949 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
950 tokenf ia2 ib2
>>= (fun ia2 ib2
->
952 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
953 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
956 (* todo?: handle some isomorphisms here ? *)
957 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
958 let (ib1) = tuple_of_list1 ii
in
959 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
960 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
961 expression ea eb
>>= (fun ea eb
->
963 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
964 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
969 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
970 let (ib1) = tuple_of_list1 ii
in
971 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
972 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
973 expression ea eb
>>= (fun ea eb
->
975 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
976 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
980 (* todo?: handle some isomorphisms here ?
981 * todo?: do some iso-by-absence on cast ?
982 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
985 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
986 let (ib1, ib2
) = tuple_of_list2 ii
in
987 fullType typa typb
>>= (fun typa typb
->
988 expression ea eb
>>= (fun ea eb
->
989 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
990 tokenf ia2 ib2
>>= (fun ia2 ib2
->
992 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
993 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
996 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
997 let ib1 = tuple_of_list1 ii
in
998 expression ea eb
>>= (fun ea eb
->
999 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1001 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1002 ((B.SizeOfExpr
(eb
), typ),[ib1])
1005 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1006 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1007 fullType typa typb
>>= (fun typa typb
->
1008 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1009 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1010 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1012 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1013 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1017 (* todo? iso ? allow all the combinations ? *)
1018 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1019 let (ib1, ib2
) = tuple_of_list2 ii
in
1020 expression ea eb
>>= (fun ea eb
->
1021 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1022 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1024 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1025 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1028 | A.NestExpr
(exps
,None
,true), eb
->
1029 (match A.unwrap exps
with
1031 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1033 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1039 "for nestexpr, only handling the case with dots and only one exp")
1041 | A.NestExpr _
, _
->
1042 failwith
"only handling multi and no when code in a nest expr"
1044 (* only in arg lists or in define body *)
1045 | A.TypeExp _
, _
-> fail
1047 (* only in arg lists *)
1048 | A.MetaExprList _
, _
1055 | A.DisjExpr
eas, eb
->
1056 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1058 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1059 failwith
"not handling Opt/Unique/Multi on expr"
1061 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1063 (* have not a counter part in coccinelle, for the moment *)
1064 | _
, ((B.Sequence _
,_
),_
)
1065 | _
, ((B.StatementExpr _
,_
),_
)
1066 | _
, ((B.Constructor _
,_
),_
)
1071 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1072 B.RecordPtAccess
(_
, _
)|
1073 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1074 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1075 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1076 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1077 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1086 (* ------------------------------------------------------------------------- *)
1087 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1088 fun infoidb ida idb
->
1090 | B.RegularName
(s, iis) ->
1091 let iis = tuple_of_list1
iis in
1092 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1095 (B.RegularName
(s, [iis]))
1097 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1100 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1101 fun infoidb ida
((idb
, iib
) as ib
) ->
1102 X.all_bound
(A.get_inherited ida
) >&&>
1103 match A.unwrap ida
with
1105 if (term sa
) =$
= idb
then
1106 tokenf sa iib
>>= (fun sa iib
->
1108 ((A.Id sa
)) +> A.rewrap ida
,
1114 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1115 X.check_constraints
(ident infoidb
) constraints ib
1117 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1118 (* use drop_pos for ids so that the pos is not added a second time in
1119 the call to tokenf *)
1120 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1122 tokenf mida iib
>>= (fun mida iib
->
1124 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1129 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1131 X.check_constraints
(ident infoidb
) constraints ib
1133 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1134 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1136 tokenf mida iib
>>= (fun mida iib
->
1138 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1143 | LocalFunction
| Function
-> is_function()
1145 failwith
"MetaFunc, need more semantic info about id"
1146 (* the following implementation could possibly be useful, if one
1147 follows the convention that a macro is always in capital letters
1148 and that a macro is not a function.
1149 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1152 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1155 X.check_constraints
(ident infoidb
) constraints ib
1157 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1158 X.envf keep inherited
1159 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1161 tokenf mida iib
>>= (fun mida iib
->
1163 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1169 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1172 | A.OptIdent _
| A.UniqueIdent _
->
1173 failwith
"not handling Opt/Unique for ident"
1177 (* ------------------------------------------------------------------------- *)
1178 and (arguments
: sequence
->
1179 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1180 fun seqstyle eas ebs
->
1182 | Unordered
-> failwith
"not handling ooo"
1184 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1185 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1187 (* because '...' can match nothing, need to take care when have
1188 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1189 * f(1,2) for instance.
1190 * So I have added special cases such as (if startxs = []) and code
1191 * in the Ecomma matching rule.
1193 * old: Must do some try, for instance when f(...,X,Y,...) have to
1194 * test the transfo for all the combinaitions and if multiple transfo
1195 * possible ? pb ? => the type is to return a expression option ? use
1196 * some combinators to help ?
1197 * update: with the tag-SP approach, no more a problem.
1200 and arguments_bis
= fun eas ebs
->
1202 | [], [] -> return ([], [])
1203 | [], eb
::ebs
-> fail
1205 X.all_bound
(A.get_inherited ea
) >&&>
1206 (match A.unwrap ea
, ebs
with
1207 | A.Edots
(mcode
, optexpr
), ys
->
1208 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1209 if optexpr
<> None
then failwith
"not handling when in argument";
1211 (* '...' can take more or less the beginnings of the arguments *)
1212 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1213 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1216 (* allow '...', and maybe its associated ',' to match nothing.
1217 * for the associated ',' see below how we handle the EComma
1222 if mcode_contain_plus (mcodekind mcode
)
1224 (* failwith "I have no token that I could accroche myself on" *)
1225 else return (dots2metavar mcode
, [])
1227 (* subtil: we dont want the '...' to match until the
1228 * comma. cf -test pb_params_iso. We would get at
1229 * "already tagged" error.
1230 * this is because both f (... x, ...) and f (..., x, ...)
1231 * would match a f(x,3) with our "optional-comma" strategy.
1233 (match Common.last startxs
with
1236 X.distrf_args
(dots2metavar mcode
) startxs
1239 >>= (fun mcode startxs
->
1240 let mcode = metavar2dots mcode in
1241 arguments_bis
eas endxs
>>= (fun eas endxs
->
1243 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1249 | A.EComma ia1
, Right ii
::ebs
->
1250 let ib1 = tuple_of_list1 ii
in
1251 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1252 arguments_bis
eas ebs
>>= (fun eas ebs
->
1254 (A.EComma ia1
+> A.rewrap ea
)::eas,
1258 | A.EComma ia1
, ebs
->
1259 (* allow ',' to maching nothing. optional comma trick *)
1260 if mcode_contain_plus (mcodekind ia1
)
1262 else arguments_bis
eas ebs
1264 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1265 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1266 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1271 if mcode_contain_plus (mcodekind ida
)
1273 (* failwith "no token that I could accroche myself on" *)
1276 (match Common.last startxs
with
1284 let startxs'
= Ast_c.unsplit_comma
startxs in
1285 let len = List.length
startxs'
in
1288 | Some
(lenname
,lenkeep
,leninherited
) ->
1289 let max_min _
= failwith
"no pos" in
1290 X.envf lenkeep leninherited
1291 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1292 | None
-> function f
-> f
()
1296 Lib_parsing_c.lin_col_by_pos
1297 (Lib_parsing_c.ii_of_args
startxs) in
1298 X.envf keep inherited
1299 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1302 then return (ida
, [])
1303 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1305 >>= (fun ida
startxs ->
1306 arguments_bis
eas endxs
>>= (fun eas endxs
->
1308 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1309 +> A.rewrap ea
::eas,
1317 | _unwrapx
, (Left eb
)::ebs
->
1318 argument ea eb
>>= (fun ea eb
->
1319 arguments_bis
eas ebs
>>= (fun eas ebs
->
1320 return (ea
::eas, Left eb
::ebs
)
1322 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1323 | _unwrapx
, [] -> fail
1327 and argument arga argb
=
1328 X.all_bound
(A.get_inherited arga
) >&&>
1329 match A.unwrap arga
, argb
with
1331 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1333 if b
|| sopt
<> None
1335 (* failwith "the argument have a storage and ast_cocci does not have"*)
1338 (* b = false and sopt = None *)
1339 fullType tya tyb
>>= (fun tya tyb
->
1341 (A.TypeExp tya
) +> A.rewrap arga
,
1342 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1347 | A.TypeExp tya
, _
-> fail
1348 | _
, Right
(B.ArgType _
) -> fail
1350 expression arga argb
>>= (fun arga argb
->
1351 return (arga
, Left argb
)
1353 | _
, Right
(B.ArgAction y
) -> fail
1356 (* ------------------------------------------------------------------------- *)
1357 (* todo? facto code with argument ? *)
1358 and (parameters
: sequence
->
1359 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1361 fun seqstyle eas ebs
->
1363 | Unordered
-> failwith
"not handling ooo"
1365 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1366 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1370 and parameters_bis
eas ebs
=
1372 | [], [] -> return ([], [])
1373 | [], eb
::ebs
-> fail
1375 (* the management of positions is inlined into each case, because
1376 sometimes there is a Param and sometimes a ParamList *)
1377 X.all_bound
(A.get_inherited ea
) >&&>
1378 (match A.unwrap ea
, ebs
with
1379 | A.Pdots
(mcode), ys
->
1381 (* '...' can take more or less the beginnings of the arguments *)
1382 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1383 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1388 if mcode_contain_plus (mcodekind mcode)
1390 (* failwith "I have no token that I could accroche myself on"*)
1391 else return (dots2metavar mcode, [])
1393 (match Common.last
startxs with
1396 X.distrf_params
(dots2metavar mcode) startxs
1398 ) >>= (fun mcode startxs ->
1399 let mcode = metavar2dots mcode in
1400 parameters_bis
eas endxs
>>= (fun eas endxs
->
1402 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1408 | A.PComma ia1
, Right ii
::ebs
->
1409 let ib1 = tuple_of_list1 ii
in
1410 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1411 parameters_bis
eas ebs
>>= (fun eas ebs
->
1413 (A.PComma ia1
+> A.rewrap ea
)::eas,
1418 | A.PComma ia1
, ebs
->
1419 (* try optional comma trick *)
1420 if mcode_contain_plus (mcodekind ia1
)
1422 else parameters_bis
eas ebs
1425 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1426 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1427 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1432 if mcode_contain_plus (mcodekind ida
)
1434 (* failwith "I have no token that I could accroche myself on" *)
1437 (match Common.last
startxs with
1445 let startxs'
= Ast_c.unsplit_comma
startxs in
1446 let len = List.length
startxs'
in
1449 Some
(lenname
,lenkeep
,leninherited
) ->
1450 let max_min _
= failwith
"no pos" in
1451 X.envf lenkeep leninherited
1452 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1453 | None
-> function f
-> f
()
1457 Lib_parsing_c.lin_col_by_pos
1458 (Lib_parsing_c.ii_of_params
startxs) in
1459 X.envf keep inherited
1460 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1463 then return (ida
, [])
1464 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1465 ) >>= (fun ida
startxs ->
1466 parameters_bis
eas endxs
>>= (fun eas endxs
->
1468 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1469 +> A.rewrap ea
::eas,
1477 | A.VoidParam ta
, ys
->
1478 (match eas, ebs
with
1480 let {B.p_register
=(hasreg
,iihasreg
);
1482 p_type
=tb
; } = eb
in
1484 if idbopt
=*= None
&& not hasreg
1487 | (qub
, (B.BaseType
B.Void
,_
)) ->
1488 fullType ta tb
>>= (fun ta tb
->
1490 [(A.VoidParam ta
) +> A.rewrap ea
],
1491 [Left
{B.p_register
=(hasreg
, iihasreg
);
1500 | (A.OptParam _
| A.UniqueParam _
), _
->
1501 failwith
"handling Opt/Unique for Param"
1503 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1506 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1507 (* todo: use quaopt, hasreg ? *)
1509 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1510 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1511 X.distrf_param ida eb
1512 ) >>= (fun ida eb
->
1513 parameters_bis
eas ebs
>>= (fun eas ebs
->
1515 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1520 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1521 (*this should succeed if the C code has a name, and fail otherwise*)
1522 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1523 parameters_bis
eas ebs
>>= (fun eas ebs
->
1525 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1529 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1530 | _unwrapx
, [] -> fail
1536 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1537 match hasreg, idb, ii_b_s with
1538 | false, Some s, [i1] -> Left (s, [], i1)
1539 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1540 | _, None, ii -> Right ii
1541 | _ -> raise Impossible
1545 and parameter
= fun (idaopt
, typa
) paramb
->
1547 let {B.p_register
= (hasreg
,iihasreg
);
1548 p_namei
= nameidbopt
;
1549 p_type
= typb
;} = paramb
in
1551 fullType typa typb
>>= (fun typa typb
->
1552 match idaopt
, nameidbopt
with
1553 | Some ida
, Some nameidb
->
1554 (* todo: if minus on ida, should also minus the iihasreg ? *)
1555 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1558 {B.p_register
= (hasreg
, iihasreg
);
1559 p_namei
= Some
(nameidb
);
1566 {B.p_register
=(hasreg
,iihasreg
);
1572 (* why handle this case ? because of transform_proto ? we may not
1573 * have an ident in the proto.
1574 * If have some plus on ida ? do nothing about ida ?
1576 (* not anymore !!! now that julia is handling the proto.
1577 | _, Right iihasreg ->
1580 ((hasreg, None, typb), iihasreg)
1584 | Some _
, None
-> fail
1585 | None
, Some _
-> fail
1591 (* ------------------------------------------------------------------------- *)
1592 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1593 fun (mckstart
, allminus
, decla
) declb
->
1594 X.all_bound
(A.get_inherited decla
) >&&>
1595 match A.unwrap decla
, declb
with
1597 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1598 * de toutes les declarations qui sont au debut d'un fonction et
1599 * commencer le reste du match au premier statement. Alors, ca matche
1600 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1601 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1603 * When the SP want to remove the whole function, the minus is not
1604 * on the MetaDecl but on the MetaRuleElem. So there should
1605 * be no transform of MetaDecl, just matching are allowed.
1608 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1609 (* todo: should not happen in transform mode *)
1610 return ((mckstart
, allminus
, decla
), declb
)
1614 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1615 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1616 (fun decla
(var
,iiptvirgb
,iisto
)->
1617 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1619 (mckstart
, allminus
, decla
),
1620 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1623 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1624 if X.mode
=*= PatternMode
1626 xs
+> List.fold_left
(fun acc var
->
1628 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1629 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1630 (fun decla
(var
, iiptvirgb
, iisto
) ->
1632 (mckstart
, allminus
, decla
),
1633 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1637 failwith
"More that one variable in decl. Have to split to transform."
1639 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1640 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1642 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1643 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1644 | _
-> raise Impossible
1647 then minusize_list iistob
1648 else return ((), iistob
)
1649 ) >>= (fun () iistob
->
1651 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1652 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1653 tokenf lpa lpb
>>= (fun lpa lpb
->
1654 tokenf rpa rpb
>>= (fun rpa rpb
->
1655 tokenf enda iiendb
>>= (fun enda iiendb
->
1656 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1657 let eas = redots
eas easundots
in
1660 (mckstart
, allminus
,
1661 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1662 (B.MacroDecl
((sb
,ebs
),
1663 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1666 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1670 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1671 X.all_bound
(A.get_inherited decla
) >&&>
1672 match A.unwrap decla
, declb
with
1674 (* kind of typedef iso, we must unfold, it's for the case
1675 * T { }; that we want to match against typedef struct { } xx_t;
1677 | A.TyDecl
(tya0
, ptvirga
),
1678 ({B.v_namei
= Some
(nameidb
, None
);
1680 B.v_storage
= (B.StoTypedef
, inl
);
1685 (match A.unwrap tya0
, typb0
with
1686 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1688 (match A.unwrap tya1
, typb1
with
1689 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1690 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1692 let (iisub
, iisbopt
, lbb
, rbb
) =
1695 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1696 (iisub
, [], lbb
, rbb
)
1699 "warning: both a typedef (%s) and struct name introduction (%s)"
1700 (Ast_c.str_of_name nameidb
) s
1702 pr2
"warning: I will consider only the typedef";
1703 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1704 (iisub
, [iisb
], lbb
, rbb
)
1707 structdef_to_struct_name
1708 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1711 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1712 (Lib_parsing_c.al_type
structnameb))), [])
1715 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1716 tokenf lba lbb
>>= (fun lba lbb
->
1717 tokenf rba rbb
>>= (fun rba rbb
->
1718 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1719 let declsa = redots
declsa undeclsa
in
1721 (match A.unwrap tya2
with
1722 | A.Type
(cv3
, tya3
) ->
1723 (match A.unwrap tya3
with
1724 | A.MetaType
(ida
,keep
, inherited
) ->
1726 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1728 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1729 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1732 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1733 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1734 let typb0 = ((qu
, il
), typb1) in
1736 match fake_typeb with
1737 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1740 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1741 (({B.v_namei
= Some
(nameidb
, None
);
1743 B.v_storage
= (B.StoTypedef
, inl
);
1747 iivirg
),iiptvirgb
,iistob
)
1749 | _
-> raise Impossible
1752 | A.StructUnionName
(sua
, sa
) ->
1754 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1756 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1758 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1760 match structnameb with
1761 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1763 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1764 [iisub
;iisbopt
;lbb
;rbb
] in
1765 let typb0 = ((qu
, il
), typb1) in
1768 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1769 (({B.v_namei
= Some
(nameidb
, None
);
1771 B.v_storage
= (B.StoTypedef
, inl
);
1775 iivirg
),iiptvirgb
,iistob
)
1777 | _
-> raise Impossible
1779 | _
-> raise Impossible
1788 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1789 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1792 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1793 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1798 (* could handle iso here but handled in standard.iso *)
1799 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1800 ({B.v_namei
= Some
(nameidb
, None
);
1807 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1808 fullType typa typb
>>= (fun typa typb
->
1809 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1810 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1811 (fun stoa
(stob
, iistob
) ->
1813 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1814 (({B.v_namei
= Some
(nameidb
, None
);
1823 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1824 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1831 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1832 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1833 fullType typa typb
>>= (fun typa typb
->
1834 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1835 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1836 (fun stoa
(stob
, iistob
) ->
1837 initialiser inia inib
>>= (fun inia inib
->
1839 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1840 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1849 (* do iso-by-absence here ? allow typedecl and var ? *)
1850 | A.TyDecl
(typa
, ptvirga
),
1851 ({B.v_namei
= None
; B.v_type
= typb
;
1857 if stob
=*= (B.NoSto
, false)
1859 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1860 fullType typa typb
>>= (fun typa typb
->
1862 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1863 (({B.v_namei
= None
;
1868 }, iivirg
), iiptvirgb
, iistob
)
1873 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1874 ({B.v_namei
= Some
(nameidb
, None
);
1876 B.v_storage
= (B.StoTypedef
,inline
);
1881 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1882 fullType typa typb
>>= (fun typa typb
->
1885 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
1886 return (stoa
, [iitypedef
])
1888 | _
-> failwith
"weird, have both typedef and inline or nothing";
1889 ) >>= (fun stoa iistob
->
1890 (match A.unwrap ida
with
1891 | A.MetaType
(_
,_
,_
) ->
1894 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
1896 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
1897 match fake_typeb with
1898 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
1899 return (ida
, nameidb
)
1900 | _
-> raise Impossible
1905 | B.RegularName
(sb
, iidb
) ->
1906 let iidb1 = tuple_of_list1 iidb
in
1910 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
1912 (A.TypeName sa
) +> A.rewrap ida
,
1913 B.RegularName
(sb
, [iidb1])
1917 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1921 | _
-> raise Impossible
1923 ) >>= (fun ida nameidb
->
1925 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1926 (({B.v_namei
= Some
(nameidb
, None
);
1928 B.v_storage
= (B.StoTypedef
,inline
);
1938 | _
, ({B.v_namei
= None
;}, _
) ->
1939 (* old: failwith "no variable in this declaration, weird" *)
1944 | A.DisjDecl declas
, declb
->
1945 declas
+> List.fold_left
(fun acc decla
->
1947 (* (declaration (mckstart, allminus, decla) declb) *)
1948 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
1953 (* only in struct type decls *)
1954 | A.Ddots
(dots
,whencode
), _
->
1957 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
1958 failwith
"not handling Opt/Unique Decl"
1960 | _
, ({B.v_namei
=Some _
}, _
) ->
1966 (* ------------------------------------------------------------------------- *)
1968 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
1969 X.all_bound
(A.get_inherited ia
) >&&>
1970 match (A.unwrap ia
,ib
) with
1972 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
1974 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
1975 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
1977 X.distrf_ini ida ib
>>= (fun ida ib
->
1979 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
1984 | (A.InitExpr expa
, ib
) ->
1985 (match A.unwrap expa
, ib
with
1986 | A.Edots
(mcode, None
), ib
->
1987 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
1990 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
1995 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1997 | _
, (B.InitExpr expb
, ii
) ->
1999 expression expa expb
>>= (fun expa expb
->
2001 (A.InitExpr expa
) +> A.rewrap ia
,
2002 (B.InitExpr expb
, ii
)
2007 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2009 | ib1::ib2
::iicommaopt
->
2010 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2011 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2012 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
2014 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2015 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2018 | _
-> raise Impossible
2021 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2022 failwith
"TODO: not handling whencode in initialisers"
2025 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2026 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2028 let iieq = tuple_of_list1 ii2
in
2030 tokenf ia2
iieq >>= (fun ia2
iieq ->
2031 designators designatorsa designatorsb
>>=
2032 (fun designatorsa designatorsb
->
2033 initialiser inia inib
>>= (fun inia inib
->
2035 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2036 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2042 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2045 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2046 initialiser inia inib
>>= (fun inia inib
->
2047 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2049 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2050 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2057 | A.IComma
(comma
), _
->
2060 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2061 failwith
"not handling Opt/Unique on initialisers"
2063 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2064 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2066 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2069 and designators dla dlb
=
2070 match (dla
,dlb
) with
2071 ([],[]) -> return ([], [])
2072 | ([],_
) | (_
,[]) -> fail
2073 | (da
::dla
,db
::dlb
) ->
2074 designator da db
>>= (fun da db
->
2075 designators dla dlb
>>= (fun dla dlb
->
2076 return (da
::dla
, db
::dlb
)))
2078 and designator da db
=
2080 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2082 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2083 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2084 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2086 A.DesignatorField
(ia1
, ida
),
2087 (B.DesignatorField idb
, [iidot
;iidb
])
2090 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2092 let (ib1, ib2
) = tuple_of_list2 ii1
in
2093 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2094 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2095 expression ea eb
>>= (fun ea eb
->
2097 A.DesignatorIndex
(ia1
,ea
,ia2
),
2098 (B.DesignatorIndex eb
, [ib1;ib2
])
2101 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2102 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2104 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2105 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2106 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2107 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2108 expression e1a e1b
>>= (fun e1a e1b
->
2109 expression e2a e2b
>>= (fun e2a e2b
->
2111 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2112 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2114 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2118 and initialisers
= fun ias
(ibs
, iicomma
) ->
2119 let ias_unsplit = unsplit_icomma ias
in
2120 let ibs_split = resplit_initialiser ibs iicomma
in
2123 if need_unordered_initialisers ibs
2124 then initialisers_unordered2
2125 else initialisers_ordered2
2127 f ias_unsplit ibs_split >>=
2128 (fun ias_unsplit ibs_split ->
2130 split_icomma ias_unsplit,
2131 unsplit_initialiser ibs_split
2135 (* todo: one day julia will reput a IDots *)
2136 and initialisers_ordered2
= fun ias ibs
->
2138 | [], [] -> return ([], [])
2139 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2140 (match A.unwrap xcomma
with
2141 | A.IComma commax
->
2142 tokenf commax commay
>>= (fun commax commay
->
2143 initialiser x y
>>= (fun x y
->
2144 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2146 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2150 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2156 and initialisers_unordered2
= fun ias ibs
->
2159 | [], ys
-> return ([], ys
)
2160 | (x
,xcomma
)::xs
, ys
->
2162 let permut = Common.uncons_permut_lazy ys
in
2163 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2166 (match A.unwrap xcomma
, e
with
2167 | A.IComma commax
, (y
, commay
) ->
2168 tokenf commax commay
>>= (fun commax commay
->
2169 initialiser x y
>>= (fun x y
->
2171 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2175 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2178 let rest = Lazy.force
rest in
2179 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2182 Common.insert_elem_pos
(e
, pos
) rest
2187 (* ------------------------------------------------------------------------- *)
2188 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2191 | [], [] -> return ([], [])
2192 | [], eb
::ebs
-> fail
2194 X.all_bound
(A.get_inherited ea
) >&&>
2195 (match A.unwrap ea
, ebs
with
2196 | A.Ddots
(mcode, optwhen
), ys
->
2197 if optwhen
<> None
then failwith
"not handling when in argument";
2199 (* '...' can take more or less the beginnings of the arguments *)
2200 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2201 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2206 if mcode_contain_plus (mcodekind mcode)
2208 (* failwith "I have no token that I could accroche myself on" *)
2209 else return (dots2metavar mcode, [])
2212 X.distrf_struct_fields
(dots2metavar mcode) startxs
2213 ) >>= (fun mcode startxs ->
2214 let mcode = metavar2dots mcode in
2215 struct_fields
eas endxs
>>= (fun eas endxs
->
2217 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2222 | _unwrapx
, eb
::ebs
->
2223 struct_field ea eb
>>= (fun ea eb
->
2224 struct_fields
eas ebs
>>= (fun eas ebs
->
2225 return (ea
::eas, eb
::ebs
)
2228 | _unwrapx
, [] -> fail
2231 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2232 let (xfield
, iifield
) = fb
in
2235 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2237 let iiptvirgb = tuple_of_list1 iiptvirg
in
2239 (match onefield_multivars
with
2240 | [] -> raise Impossible
2241 | [onevar
,iivirg
] ->
2242 assert (null iivirg
);
2244 | B.BitField
(sopt
, typb
, _
, expr
) ->
2245 pr2_once
"warning: bitfield not handled by ast_cocci";
2247 | B.Simple
(None
, typb
) ->
2248 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2250 | B.Simple
(Some nameidb
, typb
) ->
2252 (* build a declaration from a struct field *)
2253 let allminus = false in
2255 let stob = B.NoSto
, false in
2257 ({B.v_namei
= Some
(nameidb
, None
);
2260 B.v_local
= Ast_c.NotLocalDecl
;
2261 B.v_attr
= Ast_c.noattr
;
2265 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2266 (fun fa
(var
,iiptvirgb,iisto) ->
2269 | ({B.v_namei
= Some
(nameidb
, None
);
2274 let onevar = B.Simple
(Some nameidb
, typb
) in
2278 ((B.DeclarationField
2279 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb]))),
2282 | _
-> raise Impossible
2287 pr2_once
"PB: More that one variable in decl. Have to split";
2291 let _iiptvirgb = tuple_of_list1 iifield
in
2294 | B.MacroStructDeclTodo
-> fail
2295 | B.CppDirectiveStruct directive
-> fail
2296 | B.IfdefStruct directive
-> fail
2300 (* ------------------------------------------------------------------------- *)
2301 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2303 X.optional_qualifier_flag
(fun optional_qualifier
->
2304 X.all_bound
(A.get_inherited typa
) >&&>
2305 match A.unwrap typa
, typb
with
2306 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2308 if qu
.B.const
&& qu
.B.volatile
2311 ("warning: the type is both const & volatile but cocci " ^
2312 "does not handle that");
2314 (* Drop out the const/volatile part that has been matched.
2315 * This is because a SP can contain const T v; in which case
2316 * later in match_t_t when we encounter a T, we must not add in
2317 * the environment the whole type.
2322 (* "iso-by-absence" *)
2325 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2327 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2331 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2332 | false, false -> do_stuff ()
2333 | false, true -> fail
2334 | true, false -> do_stuff ()
2337 then pr2_once
"USING optional_qualifier builtin isomorphism";
2343 (* todo: can be __const__ ? can be const & volatile so
2344 * should filter instead ?
2346 (match term x
, il
with
2347 | A.Const
, [i1
] when qu
.B.const
->
2349 tokenf x i1
>>= (fun x i1
->
2350 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2352 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2356 | A.Volatile
, [i1
] when qu
.B.volatile
->
2357 tokenf x i1
>>= (fun x i1
->
2358 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2360 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2368 | A.DisjType typas
, typb
->
2370 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2372 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2373 -> failwith
"not handling Opt/Unique on type"
2378 * Why not (A.typeC, Ast_c.typeC) matcher ?
2379 * because when there is MetaType, we want that T record the whole type,
2380 * including the qualifier, and so this type (and the new_il function in
2381 * preceding function).
2384 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2386 X.all_bound
(A.get_inherited ta
) >&&>
2387 match A.unwrap ta
, tb
with
2390 | A.MetaType
(ida
,keep
, inherited
), typb
->
2392 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2393 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2394 X.distrf_type ida typb
>>= (fun ida typb
->
2396 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2400 | unwrap
, (qub
, typb
) ->
2401 typeC ta typb
>>= (fun ta typb
->
2402 return (ta
, (qub
, typb
))
2405 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2406 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2407 * And even if in baseb we have a Signed Int, that does not mean
2408 * that ii is of length 2, cos Signed is the default, so if in signa
2409 * we have Signed explicitely ? we cant "accrocher" this mcode to
2410 * something :( So for the moment when there is signed in cocci,
2411 * we force that there is a signed in c too (done in pattern.ml).
2413 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2416 (* handle some iso on type ? (cf complex C rule for possible implicit
2418 match basea
, baseb
with
2419 | A.VoidType
, B.Void
2420 | A.FloatType
, B.FloatType
(B.CFloat
)
2421 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2422 assert (signaopt
=*= None
);
2423 let stringa = tuple_of_list1 stringsa
in
2424 let (ibaseb
) = tuple_of_list1 ii
in
2425 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2427 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2428 (B.BaseType baseb
, [ibaseb
])
2431 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2432 let stringa = tuple_of_list1 stringsa
in
2433 let ibaseb = tuple_of_list1 ii
in
2434 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2436 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2437 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2440 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2441 let stringa = tuple_of_list1 stringsa
in
2442 let ibaseb = tuple_of_list1 iibaseb
in
2443 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2444 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2446 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2447 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2450 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2451 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2452 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2453 let stringa = tuple_of_list1 stringsa
in
2456 (* iso-by-presence ? *)
2457 (* when unsigned int in SP, allow have just unsigned in C ? *)
2458 if mcode_contain_plus (mcodekind stringa)
2462 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2464 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2465 (B.BaseType
(baseb
), iisignbopt
++ [])
2471 "warning: long int or short int not handled by ast_cocci";
2475 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2476 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2478 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2479 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2481 | _
-> raise Impossible
2486 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2487 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2489 [ibase1b
;ibase2b
] ->
2490 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2491 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2492 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2494 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2495 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2497 | [] -> fail (* should something be done in this case? *)
2498 | _
-> raise Impossible
)
2501 | _
, B.FloatType
B.CLongDouble
2504 "warning: long double not handled by ast_cocci";
2507 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2509 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2510 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2511 * And even if in baseb we have a Signed Int, that does not mean
2512 * that ii is of length 2, cos Signed is the default, so if in signa
2513 * we have Signed explicitely ? we cant "accrocher" this mcode to
2514 * something :( So for the moment when there is signed in cocci,
2515 * we force that there is a signed in c too (done in pattern.ml).
2517 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2519 let match_to_type rebaseb
=
2520 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2521 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2522 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2523 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2524 (match A.unwrap
fta,tb
with
2525 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2527 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2528 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2530 | _
-> failwith
"not possible"))) in
2532 (* handle some iso on type ? (cf complex C rule for possible implicit
2535 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2536 match_to_type (B.IntType
B.CChar
)
2538 | B.IntType
(B.Si
(_
, ty
)) ->
2540 | [] -> fail (* metavariable has to match something *)
2542 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2546 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2548 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2550 match A.unwrap ta
, tb
with
2551 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2552 simulate_signed ta basea stringsa None tb baseb ii
2553 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2554 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2555 (match A.unwrap basea
with
2556 A.BaseType
(basea1
,strings1
) ->
2557 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2558 (function (strings1
, Some signaopt
) ->
2561 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2562 | _
-> failwith
"not possible")
2563 | A.MetaType
(ida
,keep
,inherited
) ->
2564 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2565 (function (basea
, Some signaopt
) ->
2566 A.SignedT
(signaopt
,Some basea
)
2567 | _
-> failwith
"not possible")
2568 | _
-> failwith
"not possible")
2569 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2570 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2571 (match iibaseb
, baseb
with
2572 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2573 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2575 | None
-> raise Impossible
2578 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2579 (B.BaseType baseb
, iisignbopt
)
2587 (* todo? iso with array *)
2588 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2589 let (ibmult
) = tuple_of_list1 ii
in
2590 fullType typa typb
>>= (fun typa typb
->
2591 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2593 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2594 (B.Pointer typb
, [ibmult
])
2597 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2598 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2600 let (lpb
, rpb
) = tuple_of_list2 ii
in
2604 ("Not handling well variable length arguments func. "^
2605 "You have been warned");
2606 tokenf lpa lpb
>>= (fun lpa lpb
->
2607 tokenf rpa rpb
>>= (fun rpa rpb
->
2608 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2609 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2610 (fun paramsaundots paramsb
->
2611 let paramsa = redots
paramsa paramsaundots
in
2613 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2614 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2622 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2623 (B.ParenType t1
, ii
) ->
2624 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2625 let (qu1b
, t1b
) = t1
in
2627 | B.Pointer t2
, ii
->
2628 let (starb
) = tuple_of_list1 ii
in
2629 let (qu2b
, t2b
) = t2
in
2631 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2632 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2637 ("Not handling well variable length arguments func. "^
2638 "You have been warned");
2640 fullType tya tyb
>>= (fun tya tyb
->
2641 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2642 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2643 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2644 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2645 tokenf stara starb
>>= (fun stara starb
->
2646 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2647 (fun paramsaundots paramsb
->
2648 let paramsa = redots
paramsa paramsaundots
in
2652 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2657 (B.Pointer
t2, [starb
]))
2661 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2663 (B.ParenType
t1, [lp1b
;rp1b
])
2676 (* todo: handle the iso on optionnal size specifification ? *)
2677 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2678 let (ib1, ib2
) = tuple_of_list2 ii
in
2679 fullType typa typb
>>= (fun typa typb
->
2680 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2681 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2682 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2684 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2685 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2689 (* todo: could also match a Struct that has provided a name *)
2690 (* This is for the case where the SmPL code contains "struct x", without
2691 a definition. In this case, the name field is always present.
2692 This case is also called from the case for A.StructUnionDef when
2693 a name is present in the C code. *)
2694 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2695 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2696 let (ib1, ib2
) = tuple_of_list2 ii
in
2697 if equal_structUnion (term sua
) sub
2699 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2700 tokenf sua
ib1 >>= (fun sua
ib1 ->
2702 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2703 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2708 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2709 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2711 let (ii_sub_sb
, lbb
, rbb
) =
2713 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2714 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2715 | _
-> failwith
"list of length 3 or 4 expected" in
2718 match (sbopt
,ii_sub_sb
) with
2719 (None
,Common.Left iisub
) ->
2720 (* the following doesn't reconstruct the complete SP code, just
2721 the part that matched *)
2723 match A.unwrap
s with
2725 (match A.unwrap ty
with
2726 A.StructUnionName
(sua
, None
) ->
2727 tokenf sua iisub
>>= (fun sua iisub
->
2730 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2732 return (ty,[iisub
]))
2734 | A.DisjType
(disjs
) ->
2736 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2740 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2742 (* build a StructUnionName from a StructUnion *)
2743 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2745 fullType
ty fake_su >>= (fun ty fake_su ->
2747 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2748 return (ty, [iisub
; iisb
])
2749 | _
-> raise Impossible
)
2753 >>= (fun ty ii_sub_sb
->
2755 tokenf lba lbb
>>= (fun lba lbb
->
2756 tokenf rba rbb
>>= (fun rba rbb
->
2757 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2758 let declsa = redots
declsa undeclsa
in
2761 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2762 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2766 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2767 * uint in the C code. But some CEs consists in renaming some types,
2768 * so we don't want apply isomorphisms every time.
2770 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2774 | B.RegularName
(sb
, iidb
) ->
2775 let iidb1 = tuple_of_list1 iidb
in
2779 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2781 (A.TypeName sa
) +> A.rewrap ta
,
2782 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2786 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2791 | _
, (B.TypeOfExpr e
, ii
) -> fail
2792 | _
, (B.TypeOfType e
, ii
) -> fail
2794 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2795 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
2796 let (ib1,ib2
) = tuple_of_list2 ii
in
2797 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2798 tokenf en
ib1 >>= (fun en
ib1 ->
2800 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
2801 (B.EnumName nameb
, [ib1;ib2
])
2804 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
2807 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
2808 B.StructUnion
(_
, _
, _
) |
2809 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
2815 (* todo: iso on sign, if not mentioned then free. tochange?
2816 * but that require to know if signed int because explicit
2817 * signed int, or because implicit signed int.
2820 and sign signa signb
=
2821 match signa
, signb
with
2822 | None
, None
-> return (None
, [])
2823 | Some signa
, Some
(signb
, ib
) ->
2824 if equal_sign (term signa
) signb
2825 then tokenf signa ib
>>= (fun signa ib
->
2826 return (Some signa
, [ib
])
2832 and minusize_list iixs
=
2833 iixs
+> List.fold_left
(fun acc ii
->
2834 acc
>>= (fun xs ys
->
2835 tokenf minusizer ii
>>= (fun minus ii
->
2836 return (minus
::xs
, ii
::ys
)
2837 ))) (return ([],[]))
2838 >>= (fun _xsminys ys
->
2839 return ((), List.rev ys
)
2842 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
2843 (* "iso-by-absence" for storage, and return type. *)
2844 X.optional_storage_flag
(fun optional_storage
->
2845 match stoa
, stob with
2846 | None
, (stobis
, inline
) ->
2850 minusize_list iistob
>>= (fun () iistob
->
2851 return (None
, (stob, iistob
))
2853 else return (None
, (stob, iistob
))
2856 (match optional_storage
, stobis
with
2857 | false, B.NoSto
-> do_minus ()
2859 | true, B.NoSto
-> do_minus ()
2862 then pr2_once
"USING optional_storage builtin isomorphism";
2866 | Some x
, ((stobis
, inline
)) ->
2867 if equal_storage (term x
) stobis
2871 tokenf x i1
>>= (fun x i1
->
2872 return (Some x
, ((stobis
, inline
), [i1
]))
2874 (* or if have inline ? have to do a split_storage_inline a la
2875 * split_signb_baseb_ii *)
2876 | _
-> raise Impossible
2884 and fullType_optional_allminus
allminus tya retb
=
2889 X.distrf_type
minusizer retb
>>= (fun _x retb
->
2893 else return (None
, retb
)
2895 fullType tya retb
>>= (fun tya retb
->
2896 return (Some tya
, retb
)
2901 (*---------------------------------------------------------------------------*)
2903 and compatible_base_type a signa b
=
2904 let ok = return ((),()) in
2907 | Type_cocci.VoidType
, B.Void
->
2908 assert (signa
=*= None
);
2910 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
2912 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2913 compatible_sign signa signb
2914 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
2915 compatible_sign signa signb
2916 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
2917 compatible_sign signa signb
2918 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
2919 compatible_sign signa signb
2920 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
2921 pr2_once
"no longlong in cocci";
2923 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
2924 assert (signa
=*= None
);
2926 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
2927 assert (signa
=*= None
);
2929 | _
, B.FloatType
B.CLongDouble
->
2930 pr2_once
"no longdouble in cocci";
2932 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
2934 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2936 and compatible_base_type_meta a signa qua b ii
local =
2938 | Type_cocci.MetaType
(ida
,keep
,inherited
),
2939 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2940 compatible_sign signa signb
>>= fun _ _
->
2941 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
2942 compatible_type a
newb
2943 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
2944 compatible_sign signa signb
>>= fun _ _
->
2946 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
2947 compatible_type a
newb
2948 | _
, B.FloatType
B.CLongDouble
->
2949 pr2_once
"no longdouble in cocci";
2952 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2955 and compatible_type a
(b
,local) =
2956 let ok = return ((),()) in
2958 let rec loop = function
2959 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
2960 compatible_base_type a None b
2962 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
2963 compatible_base_type
Type_cocci.IntType
(Some signa
) b
2965 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
2967 Type_cocci.BaseType
ty ->
2968 compatible_base_type
ty (Some signa
) b
2969 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
2970 compatible_base_type_meta
ty (Some signa
) qua b ii
local
2971 | _
-> failwith
"not possible")
2973 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
2975 | Type_cocci.FunctionPointer a
, _
->
2977 "TODO: function pointer type doesn't store enough information to determine compatability"
2978 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
2979 (* no size info for cocci *)
2981 | Type_cocci.StructUnionName
(sua
, _
, sa
),
2982 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
2983 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
2986 | Type_cocci.EnumName
(_
, sa
),
2987 (qub
, (B.EnumName
(sb
),ii
)) ->
2991 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
2992 let sb = Ast_c.str_of_name namesb
in
2997 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
2998 if (fst qub
).B.const
&& (fst qub
).B.volatile
3001 pr2_once
("warning: the type is both const & volatile but cocci " ^
3002 "does not handle that");
3008 | Type_cocci.Const
-> (fst qub
).B.const
3009 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3011 then loop (a
,(Ast_c.nQ
, b
))
3014 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3016 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3017 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3021 (* subtil: must be after the MetaType case *)
3022 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3023 (* kind of typedef iso *)
3030 (* for metavariables of type expression *^* *)
3031 | Type_cocci.Unknown
, _
-> ok
3036 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3037 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3044 B.StructUnionName
(_
, _
)|
3046 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3055 and compatible_sign signa signb
=
3056 let ok = return ((),()) in
3057 match signa
, signb
with
3059 | Some
Type_cocci.Signed
, B.Signed
3060 | Some
Type_cocci.Unsigned
, B.UnSigned
3065 and equal_structUnion_type_cocci a b
=
3067 | Type_cocci.Struct
, B.Struct
-> true
3068 | Type_cocci.Union
, B.Union
-> true
3069 | _
, (B.Struct
| B.Union
) -> false
3073 (*---------------------------------------------------------------------------*)
3074 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3076 let rec aux_inc (ass
, bss
) passed
=
3080 let passed = List.rev
passed in
3082 (match before_after
, !h_rel_pos
with
3083 | IncludeNothing
, _
-> true
3084 | IncludeMcodeBefore
, Some x
->
3085 List.mem
passed (x
.Ast_c.first_of
)
3087 | IncludeMcodeAfter
, Some x
->
3088 List.mem
passed (x
.Ast_c.last_of
)
3090 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3094 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3095 | _
-> failwith
"IncDots not in last place or other pb"
3100 | A.Local ass
, B.Local bss
->
3101 aux_inc (ass
, bss
) []
3102 | A.NonLocal ass
, B.NonLocal bss
->
3103 aux_inc (ass
, bss
) []
3108 (*---------------------------------------------------------------------------*)
3110 and (define_params
: sequence
->
3111 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3112 fun seqstyle eas ebs
->
3114 | Unordered
-> failwith
"not handling ooo"
3116 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3117 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3120 (* todo? facto code with argument and parameters ? *)
3121 and define_paramsbis
= fun eas ebs
->
3123 | [], [] -> return ([], [])
3124 | [], eb
::ebs
-> fail
3126 X.all_bound
(A.get_inherited ea
) >&&>
3127 (match A.unwrap ea
, ebs
with
3128 | A.DPdots
(mcode), ys
->
3130 (* '...' can take more or less the beginnings of the arguments *)
3131 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3132 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3137 if mcode_contain_plus (mcodekind mcode)
3139 (* failwith "I have no token that I could accroche myself on" *)
3140 else return (dots2metavar mcode, [])
3142 (match Common.last
startxs with
3145 X.distrf_define_params
(dots2metavar mcode) startxs
3147 ) >>= (fun mcode startxs ->
3148 let mcode = metavar2dots mcode in
3149 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3151 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3157 | A.DPComma ia1
, Right ii
::ebs
->
3158 let ib1 = tuple_of_list1 ii
in
3159 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3160 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3162 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3167 | A.DPComma ia1
, ebs
->
3168 if mcode_contain_plus (mcodekind ia1
)
3171 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3173 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3174 failwith
"handling Opt/Unique for define parameters"
3176 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3178 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3179 let ib1 = tuple_of_list1 ii
in
3180 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3181 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3183 (A.DParam ida
)+> A.rewrap ea
:: eas,
3184 (Left
(idb
, [ib1]))::ebs
3187 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3188 | _unwrapx
, [] -> fail
3193 (*****************************************************************************)
3195 (*****************************************************************************)
3197 (* no global solution for positions here, because for a statement metavariable
3198 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3200 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3203 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3205 X.all_bound
(A.get_inherited re
) >&&>
3208 match A.unwrap re
, F.unwrap node
with
3210 (* note: the order of the clauses is important. *)
3212 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3214 (* the metaRuleElem contains just '-' information. We dont need to add
3215 * stuff in the environment. If we need stuff in environment, because
3216 * there is a + S somewhere, then this will be done via MetaStmt, not
3218 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3221 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3222 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3223 (match unwrap_node
with
3225 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
3227 if X.mode
=*= PatternMode
3230 if mcode_contain_plus (mcodekind mcode)
3231 then failwith
"try add stuff on fake node"
3232 (* minusize or contextize a fake node is ok *)
3235 | F.EndStatement None
->
3236 if X.mode
=*= PatternMode
then return default
3238 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3239 if mcode_contain_plus (mcodekind mcode)
3241 let fake_info = Ast_c.fakeInfo() in
3242 distrf distrf_node (mcodekind mcode)
3243 (F.EndStatement (Some fake_info))
3244 else return unwrap_node
3248 | F.EndStatement
(Some i1
) ->
3249 tokenf mcode i1
>>= (fun mcode i1
->
3251 A.MetaRuleElem
(mcode,keep
, inherited
),
3252 F.EndStatement
(Some i1
)
3256 if X.mode
=*= PatternMode
then return default
3257 else failwith
"a MetaRuleElem can't transform a headfunc"
3259 if X.mode
=*= PatternMode
then return default
3261 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3263 A.MetaRuleElem
(mcode,keep
, inherited
),
3269 (* rene cant have found that a state containing a fake/exit/... should be
3271 * TODO: and F.Fake ?
3273 | _
, F.EndStatement _
| _
, F.CaseNode _
3274 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
| _
, F.FallThroughNode
3278 (* really ? diff between pattern.ml and transformation.ml *)
3279 | _
, F.Fake
-> fail2()
3282 (* cas general: a Meta can match everything. It matches only
3283 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3284 * So can't have been called in transform.
3286 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3288 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3289 (* todo: should not happen in transform mode *)
3291 (match Control_flow_c.extract_fullstatement node
with
3294 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3295 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3297 (* no need tag ida, we can't be called in transform-mode *)
3299 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3307 | A.MetaStmtList _
, _
->
3308 failwith
"not handling MetaStmtList"
3310 | A.TopExp ea
, F.DefineExpr eb
->
3311 expression ea eb
>>= (fun ea eb
->
3317 | A.TopExp ea
, F.DefineType eb
->
3318 (match A.unwrap ea
with
3320 fullType ft eb
>>= (fun ft eb
->
3322 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3329 (* It is important to put this case before the one that fails because
3330 * of the lack of the counter part of a C construct in SmPL (for instance
3331 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3332 * yet certain constructs, those constructs may contain expression
3333 * that we still want and can transform.
3336 | A.Exp exp
, nodeb
->
3338 (* kind of iso, initialisation vs affectation *)
3340 match A.unwrap exp
, nodeb
with
3341 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3342 initialisation_to_affectation decl
+> F.rewrap node
3347 (* Now keep fullstatement inside the control flow node,
3348 * so that can then get in a MetaStmtVar the fullstatement to later
3349 * pp back when the S is in a +. But that means that
3350 * Exp will match an Ifnode even if there is no such exp
3351 * inside the condition of the Ifnode (because the exp may
3352 * be deeper, in the then branch). So have to not visit
3353 * all inside a node anymore.
3355 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3356 * fois le fullstatement et le partialstatement et appeler le
3357 * visiteur que sur le partialstatement.
3360 match Ast_cocci.get_pos re
with
3361 | None
-> expression
3365 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3366 let keep = Type_cocci.Unitary
in
3367 let inherited = false in
3368 let max_min _
= failwith
"no pos" in
3369 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3375 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3383 X.cocciTy fullType
ty node >>= (fun ty node ->
3390 | A.TopInit init
, nodeb
->
3391 X.cocciInit initialiser init
node >>= (fun init
node ->
3399 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3400 F.FunHeader
({B.f_name
= nameidb
;
3401 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3405 f_old_c_style
= oldstyle
;
3410 then pr2
"OLD STYLE DECL NOT WELL SUPPORTED";
3413 (* fninfoa records the order in which the SP specified the various
3414 information, but this isn't taken into account in the matching.
3415 Could this be a problem for transformation? *)
3418 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3419 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3421 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3422 with [A.FType
(t
)] -> Some t
| _
-> None
in
3424 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3425 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3427 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3428 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3431 | ioparenb
::icparenb
::iifakestart
::iistob
->
3433 (* maybe important to put ident as the first tokens to transform.
3434 * It's related to transform_proto. So don't change order
3437 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3438 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3439 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3440 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3441 parameters
(seqstyle paramsa)
3442 (A.undots
paramsa) paramsb
>>=
3443 (fun paramsaundots paramsb
->
3444 let paramsa = redots
paramsa paramsaundots
in
3445 storage_optional_allminus
allminus
3446 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3451 ("Not handling well variable length arguments func. "^
3452 "You have been warned");
3454 then minusize_list iidotsb
3455 else return ((),iidotsb
)
3456 ) >>= (fun () iidotsb
->
3458 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3461 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3462 (match tya with Some t
-> [A.FType t
] | None
-> [])
3467 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3469 F.FunHeader
({B.f_name
= nameidb
;
3470 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3474 f_old_c_style
= oldstyle
; (* TODO *)
3476 ioparenb
::icparenb
::iifakestart
::iistob
)
3479 | _
-> raise Impossible
3487 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3488 declaration
(mckstart
,allminus,decla
) declb
>>=
3489 (fun (mckstart
,allminus,decla
) declb
->
3491 A.Decl
(mckstart
,allminus,decla
),
3496 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3497 tokenf mcode i1
>>= (fun mcode i1
->
3500 F.SeqStart
(st
, level
, i1
)
3503 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3504 tokenf mcode i1
>>= (fun mcode i1
->
3507 F.SeqEnd
(level
, i1
)
3510 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3511 let ib1 = tuple_of_list1 ii
in
3512 expression ea eb
>>= (fun ea eb
->
3513 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3515 A.ExprStatement
(ea
, ia1
),
3516 F.ExprStatement
(st
, (Some eb
, [ib1]))
3521 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3522 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3523 expression ea eb
>>= (fun ea eb
->
3524 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3525 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3526 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3528 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3529 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3532 | A.Else ia
, F.Else ib
->
3533 tokenf ia ib
>>= (fun ia ib
->
3534 return (A.Else ia
, F.Else ib
)
3537 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3538 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3539 expression ea eb
>>= (fun ea eb
->
3540 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3541 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3542 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3544 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3545 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3548 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3549 tokenf ia ib
>>= (fun ia ib
->
3554 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3555 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3556 expression ea eb
>>= (fun ea eb
->
3557 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3558 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3559 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3560 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3562 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3563 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3565 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3567 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3569 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3570 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3571 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3572 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3573 let eas = redots
eas easundots
in
3575 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3576 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3581 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3582 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3584 assert (null ib4vide
);
3585 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3586 let ib3 = tuple_of_list1 ib3s
in
3587 let ib4 = tuple_of_list1 ib4s
in
3589 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3590 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3591 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3592 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3593 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3594 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3595 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3596 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3598 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3599 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3605 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3606 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3607 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3608 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3609 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3610 expression ea eb
>>= (fun ea eb
->
3612 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3613 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3616 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3617 let (ib1, ib2
) = tuple_of_list2 ii
in
3618 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3619 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3622 F.Break
(st
, ((),[ib1;ib2
]))
3625 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3626 let (ib1, ib2
) = tuple_of_list2 ii
in
3627 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3628 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3630 A.Continue
(ia1
, ia2
),
3631 F.Continue
(st
, ((),[ib1;ib2
]))
3634 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3635 let (ib1, ib2
) = tuple_of_list2 ii
in
3636 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3637 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3639 A.Return
(ia1
, ia2
),
3640 F.Return
(st
, ((),[ib1;ib2
]))
3643 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3644 let (ib1, ib2
) = tuple_of_list2 ii
in
3645 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3646 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3647 expression ea eb
>>= (fun ea eb
->
3649 A.ReturnExpr
(ia1
, ea
, ia2
),
3650 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3655 | A.Include
(incla
,filea
),
3656 F.Include
{B.i_include
= (fileb
, ii
);
3657 B.i_rel_pos
= h_rel_pos
;
3658 B.i_is_in_ifdef
= inifdef
;
3661 assert (copt
=*= None
);
3663 let include_requirment =
3664 match mcodekind incla
, mcodekind filea
with
3665 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3667 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3673 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3674 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3676 tokenf incla inclb
>>= (fun incla inclb
->
3677 tokenf filea iifileb
>>= (fun filea iifileb
->
3679 A.Include
(incla
, filea
),
3680 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3681 B.i_rel_pos
= h_rel_pos
;
3682 B.i_is_in_ifdef
= inifdef
;
3690 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3691 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3692 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3693 tokenf definea defineb
>>= (fun definea defineb
->
3694 (match A.unwrap params
, defkind
with
3695 | A.NoParams
, B.DefineVar
->
3697 A.NoParams
+> A.rewrap params
,
3700 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3701 let (lpb
, rpb
) = tuple_of_list2 ii
in
3702 tokenf lpa lpb
>>= (fun lpa lpb
->
3703 tokenf rpa rpb
>>= (fun rpa rpb
->
3705 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3706 (fun easundots ebs
->
3707 let eas = redots
eas easundots
in
3709 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3710 B.DefineFunc
(ebs
,[lpb
;rpb
])
3714 ) >>= (fun params defkind
->
3716 A.DefineHeader
(definea
, ida
, params
),
3717 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3722 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3723 let (ib1, ib2
) = tuple_of_list2 ii
in
3724 tokenf def
ib1 >>= (fun def
ib1 ->
3725 tokenf colon ib2
>>= (fun colon ib2
->
3727 A.Default
(def
,colon
),
3728 F.Default
(st
, ((),[ib1;ib2
]))
3733 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3734 let (ib1, ib2
) = tuple_of_list2 ii
in
3735 tokenf case
ib1 >>= (fun case
ib1 ->
3736 expression ea eb
>>= (fun ea eb
->
3737 tokenf colon ib2
>>= (fun colon ib2
->
3739 A.Case
(case
,ea
,colon
),
3740 F.Case
(st
, (eb
,[ib1;ib2
]))
3743 (* only occurs in the predicates generated by asttomember *)
3744 | A.DisjRuleElem
eas, _
->
3746 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3747 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3749 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3751 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
3752 let (ib2
) = tuple_of_list1 ii
in
3753 (match A.unwrap id
with
3755 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
3756 tokenf dd ib2
>>= (fun dd ib2
->
3759 F.Label
(st
,nameb
, ((),[ib2
]))
3761 | _
-> failwith
"labels with metavariables not supported"
3764 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
3765 let (ib1,ib3) = tuple_of_list2 ii
in
3766 tokenf goto
ib1 >>= (fun goto
ib1 ->
3767 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
3768 tokenf sem
ib3 >>= (fun sem
ib3 ->
3770 A.Goto
(goto
,id
,sem
),
3771 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
3774 (* have not a counter part in coccinelle, for the moment *)
3775 (* todo?: print a warning at least ? *)
3781 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3785 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3788 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3789 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3790 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3791 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3792 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3793 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3794 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3795 F.Decl _
|F.FunHeader _
)