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 (*****************************************************************************)
33 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
35 (*****************************************************************************)
37 (*****************************************************************************)
39 type sequence
= Ordered
| Unordered
42 match A.unwrap eas
with
44 | A.CIRCLES _
-> Unordered
45 | A.STARS _
-> failwith
"not handling stars"
47 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
49 match A.unwrap eas
with
50 | A.DOTS _
-> A.DOTS easundots
51 | A.CIRCLES _
-> A.CIRCLES easundots
52 | A.STARS _
-> A.STARS easundots
56 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
58 ibs
+> List.exists
(fun (ib
, icomma
) ->
59 match B.unwrap ib
with
69 (* For the #include <linux/...> in the .cocci, need to find where is
70 * the '+' attached to this element, to later find the first concrete
71 * #include <linux/xxx.h> or last one in the serie of #includes in the
74 type include_requirement
=
81 (* todo? put in semantic_c.ml *)
84 | LocalFunction
(* entails Function *)
88 let term mc
= A.unwrap_mcode mc
89 let mcodekind mc
= A.get_mcodekind mc
92 let mcode_contain_plus = function
93 | A.CONTEXT
(_
,A.NOTHING
) -> false
95 | A.MINUS
(_
,_
,_
,[]) -> false
96 | A.MINUS
(_
,_
,_
,x
::xs
) -> true
97 | A.PLUS
-> raise Impossible
99 let mcode_simple_minus = function
100 | A.MINUS
(_
,_
,_
,[]) -> true
104 (* In transformation.ml sometime I build some mcodekind myself and
105 * julia has put None for the pos. But there is no possible raise
106 * NoMatch in those cases because it is for the minusall trick or for
107 * the distribute, so either have to build those pos, in fact a range,
108 * because for the distribute have to erase a fullType with one
109 * mcodekind, or add an argument to tag_with_mck such as "safe" that
110 * don't do the check_pos. Hence this DontCarePos constructor. *)
114 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[];},
115 (A.MINUS
(A.DontCarePos
,[],-1,[])),
118 let generalize_mcode ia
=
119 let (s1
, i
, mck
, pos
) = ia
in
122 | A.PLUS
-> raise Impossible
123 | A.CONTEXT
(A.NoPos
,x
) ->
124 A.CONTEXT
(A.DontCarePos
,x
)
125 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
126 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
128 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
129 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
133 (s1
, i
, new_mck, pos
)
137 (*---------------------------------------------------------------------------*)
139 (* 0x0 is equivalent to 0, value format isomorphism *)
140 let equal_c_int s1 s2
=
142 int_of_string s1
=|= int_of_string s2
143 with Failure
("int_of_string") ->
148 (*---------------------------------------------------------------------------*)
149 (* Normally A should reuse some types of Ast_c, so those
150 * functions should not exist.
152 * update: but now Ast_c depends on A, so can't make too
153 * A depends on Ast_c, so have to stay with those equal_xxx
157 let equal_unaryOp a b
=
159 | A.GetRef
, B.GetRef
-> true
160 | A.DeRef
, B.DeRef
-> true
161 | A.UnPlus
, B.UnPlus
-> true
162 | A.UnMinus
, B.UnMinus
-> true
163 | A.Tilde
, B.Tilde
-> true
164 | A.Not
, B.Not
-> true
165 | _
, B.GetRefLabel
-> false (* todo cocci? *)
166 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
) -> false
170 let equal_arithOp a b
=
172 | A.Plus
, B.Plus
-> true
173 | A.Minus
, B.Minus
-> true
174 | A.Mul
, B.Mul
-> true
175 | A.Div
, B.Div
-> true
176 | A.Mod
, B.Mod
-> true
177 | A.DecLeft
, B.DecLeft
-> true
178 | A.DecRight
, B.DecRight
-> true
179 | A.And
, B.And
-> true
180 | A.Or
, B.Or
-> true
181 | A.Xor
, B.Xor
-> true
182 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
185 let equal_logicalOp a b
=
187 | A.Inf
, B.Inf
-> true
188 | A.Sup
, B.Sup
-> true
189 | A.InfEq
, B.InfEq
-> true
190 | A.SupEq
, B.SupEq
-> true
191 | A.Eq
, B.Eq
-> true
192 | A.NotEq
, B.NotEq
-> true
193 | A.AndLog
, B.AndLog
-> true
194 | A.OrLog
, B.OrLog
-> true
195 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
198 let equal_assignOp a b
=
200 | A.SimpleAssign
, B.SimpleAssign
-> true
201 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
202 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
204 let equal_fixOp a b
=
206 | A.Dec
, B.Dec
-> true
207 | A.Inc
, B.Inc
-> true
208 | _
, (B.Inc
|B.Dec
) -> false
210 let equal_binaryOp a b
=
212 | A.Arith a
, B.Arith b
-> equal_arithOp a b
213 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
214 | _
, (B.Logical _
| B.Arith _
) -> false
216 let equal_structUnion a b
=
218 | A.Struct
, B.Struct
-> true
219 | A.Union
, B.Union
-> true
220 | _
, (B.Struct
|B.Union
) -> false
224 | A.Signed
, B.Signed
-> true
225 | A.Unsigned
, B.UnSigned
-> true
226 | _
, (B.UnSigned
|B.Signed
) -> false
228 let equal_storage a b
=
230 | A.Static
, B.Sto
B.Static
231 | A.Auto
, B.Sto
B.Auto
232 | A.Register
, B.Sto
B.Register
233 | A.Extern
, B.Sto
B.Extern
235 | _
, (B.NoSto
| B.StoTypedef
) -> false
236 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
239 (*---------------------------------------------------------------------------*)
241 let equal_metavarval valu valu'
=
242 match valu
, valu'
with
243 | Ast_c.MetaIdVal a
, Ast_c.MetaIdVal b
-> a
=$
= b
244 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
245 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
246 (* do something more ? *)
249 (* al_expr before comparing !!! and accept when they match.
250 * Note that here we have Astc._expression, so it is a match
251 * modulo isomorphism (there is no metavariable involved here,
252 * just isomorphisms). => TODO call isomorphism_c_c instead of
253 * =*=. Maybe would be easier to transform ast_c in ast_cocci
254 * and call the iso engine of julia. *)
255 | Ast_c.MetaExprVal a
, Ast_c.MetaExprVal b
->
256 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
257 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
258 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
260 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
261 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
262 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
263 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
264 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
265 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
268 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
270 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
271 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
272 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
273 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
275 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
276 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
278 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
280 (function (fla
,cea
,posa1
,posa2
) ->
282 (function (flb
,ceb
,posb1
,posb2
) ->
283 fla
=$
= flb
&& cea
=$
= ceb
&&
284 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
288 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
289 |B.MetaTypeVal _
|B.MetaInitVal _
290 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
291 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
296 (*---------------------------------------------------------------------------*)
297 (* could put in ast_c.ml, next to the split/unsplit_comma *)
298 let split_signb_baseb_ii (baseb
, ii
) =
299 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
300 match baseb
, iis with
302 | B.Void
, ["void",i1
] -> None
, [i1
]
304 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
305 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
306 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
308 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
311 | B.IntType
(B.Si
(sign
, base
)), xs
->
315 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
316 | (B.Signed
,rest
) -> (None
,rest
)
317 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
318 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
319 (* The original code only allowed explicit signed and unsigned for char,
320 while this code allows char by itself. Not sure that needs to be
321 checked for here. If it does, then add a special case. *)
323 match (base
,rest
) with
324 B.CInt
, ["int",i1
] -> [i1
]
327 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
328 (match i1
.B.pinfo
with
330 | _
-> failwith
("unrecognized signed int: "^
331 (String.concat
" "(List.map fst
iis))))
333 | B.CChar2
, ["char",i2
] -> [i2
]
335 | B.CShort
, ["short",i1
] -> [i1
]
336 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
338 | B.CLong
, ["long",i1
] -> [i1
]
339 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
341 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
342 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
345 failwith
("strange type1, maybe because of weird order: "^
346 (String.concat
" " (List.map fst
iis))) in
348 | _
-> failwith
("strange type2, maybe because of weird order: "^
349 (String.concat
" " (List.map fst
iis)))
351 (*---------------------------------------------------------------------------*)
353 let rec unsplit_icomma xs
=
357 (match A.unwrap y
with
359 (x
, y
)::unsplit_icomma xs
360 | _
-> failwith
"wrong ast_cocci in initializer"
363 failwith
("wrong ast_cocci in initializer, should have pair " ^
368 let resplit_initialiser ibs iicomma
=
369 match iicomma
, ibs
with
372 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
374 failwith
"shouldn't have a iicomma"
375 | [iicomma
], x
::xs
->
376 let elems = List.map fst
(x
::xs
) in
377 let commas = List.map snd
(x
::xs
) +> List.flatten
in
378 let commas = commas @ [iicomma
] in
380 | _
-> raise Impossible
384 let rec split_icomma xs
=
387 | (x
,y
)::xs
-> x
::y
::split_icomma xs
389 let rec unsplit_initialiser ibs_unsplit
=
390 match ibs_unsplit
with
391 | [] -> [], [] (* empty iicomma *)
393 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
394 (x
, [])::xs
, lastcomma
396 and unsplit_initialiser_bis comma_before
= function
397 | [] -> [], [comma_before
]
399 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
400 (x
, [comma_before
])::xs
, lastcomma
405 (*---------------------------------------------------------------------------*)
406 (* coupling: same in type_annotater_c.ml *)
407 let structdef_to_struct_name ty
=
409 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
411 | Some s
, [i1
;i2
;i3
;i4
] ->
412 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
416 | x
-> raise Impossible
418 | _
-> raise Impossible
420 (*---------------------------------------------------------------------------*)
421 let initialisation_to_affectation decl
=
423 | B.MacroDecl _
-> F.Decl decl
424 | B.DeclList
(xs
, iis) ->
426 (* todo?: should not do that if the variable is an array cos
427 * will have x[] = , mais de toute facon ca sera pas un InitExp
430 | [] -> raise Impossible
432 let ({B.v_namei
= var
;
433 B.v_type
= returnType
;
434 B.v_storage
= storage
;
439 | Some
(name
, iniopt
) ->
441 | Some
(iini
, (B.InitExpr e
, ii_empty2
)) ->
442 let iis = Ast_c.info_of_name name
in
445 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
446 | Ast_c.LocalDecl
-> Ast_c.LocalVar
(iis.Ast_c.pinfo
) in
449 ref (Some
((Lib_parsing_c.al_type returnType
),local),
453 Ast_c.mk_e_bis
(B.Ident
(ident)) typ Ast_c.noii
457 (B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
465 pr2_once
"TODO: initialisation_to_affectation for multi vars";
466 (* todo? do a fold_left and generate 'x = a, y = b' etc, use
467 * the Sequence expression operator of C and make an
468 * ExprStatement from that.
477 (*****************************************************************************)
478 (* Functor parameter combinators *)
479 (*****************************************************************************)
481 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
483 * version0: was not tagging the SP, so just tag the C
485 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
486 * val return : 'b -> tin -> 'b tout
487 * val fail : tin -> 'b tout
489 * version1: now also tag the SP so return a ('a * 'b)
492 type mode
= PatternMode
| TransformMode
500 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
505 (tin
-> ('a
* 'b
) tout
) ->
506 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
507 (tin
-> ('c
* 'd
) tout
)
509 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
510 val fail
: tin
-> ('a
* 'b
) tout
522 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
524 val tokenf
: ('a
A.mcode
, B.info
) matcher
525 val tokenf_mck
: (A.mcodekind, B.info
) matcher
528 (A.meta_name
A.mcode
, B.expression
) matcher
530 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
532 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
534 (A.meta_name
A.mcode
,
535 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
537 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
539 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
541 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
543 val distrf_define_params
:
544 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
)
547 val distrf_struct_fields
:
548 (A.meta_name
A.mcode
, B.field list
) matcher
551 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
554 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
557 (A.expression
, B.expression
) matcher
->
558 (A.expression
, B.expression
) matcher
561 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
564 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
567 A.keep_binding
-> A.inherited
->
568 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
569 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
570 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
572 val check_constraints
:
573 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
574 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
576 val all_bound
: A.meta_name list
-> (tin
-> bool)
578 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
579 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
580 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
585 (*****************************************************************************)
586 (* Functor code, "Cocci vs C" *)
587 (*****************************************************************************)
590 functor (X
: PARAM
) ->
593 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
596 let return = X.return
599 let (>||>) = X.(>||>)
600 let (>|+|>) = X.(>|+|>)
601 let (>&&>) = X.(>&&>)
603 let tokenf = X.tokenf
605 (* should be raise Impossible when called from transformation.ml *)
608 | PatternMode
-> fail
609 | TransformMode
-> raise Impossible
612 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
614 | (Some t1
, Some t2
) ->
615 f t1 t2
>>= (fun t1 t2
->
616 return (Some t1
, Some t2
)
618 | (None
, None
) -> return (None
, None
)
621 (* Dots are sometimes used as metavariables, since like metavariables they
622 can match other things. But they no longer have the same type. Perhaps these
623 functions could be avoided by introducing an appropriate level of polymorphism,
624 but I don't know how to declare polymorphism across functors *)
625 let dots2metavar (_
,info
,mcodekind,pos
) = (("","..."),info
,mcodekind,pos
)
626 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
628 (*---------------------------------------------------------------------------*)
640 (*---------------------------------------------------------------------------*)
641 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
643 X.all_bound
(A.get_inherited ea
) >&&>
644 let wa x
= A.rewrap ea x
in
645 match A.unwrap ea
, eb
with
647 (* general case: a MetaExpr can match everything *)
648 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
649 (((expr
, opttypb
), ii
) as expb
) ->
651 (* old: before have a MetaConst. Now we factorize and use 'form' to
652 * differentiate between different cases *)
653 let rec matches_id = function
654 B.Ident
(name
) -> true
655 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
658 match (form
,expr
) with
661 let rec matches = function
662 B.Constant
(c
) -> true
663 | B.Ident
(nameidb
) ->
664 let s = Ast_c.str_of_name nameidb
in
665 if s =~
"^[A-Z_][A-Z_0-9]*$"
667 pr2_once
("warning: I consider " ^
s ^
" as a constant");
671 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
672 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
673 | B.SizeOfExpr
(exp
) -> true
674 | B.SizeOfType
(ty
) -> true
680 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
682 | (A.ID
,e
) -> matches_id e
in
686 (let (opttypb
,_testb
) = !opttypb
in
687 match opttypa
, opttypb
with
688 | None
, _
-> return ((),())
690 pr2_once
("Missing type information. Certainly a pb in " ^
691 "annotate_typer.ml");
694 | Some tas
, Some tb
->
695 tas
+> List.fold_left
(fun acc ta
->
696 acc
>|+|> compatible_type ta tb
) fail
699 X.check_constraints expression constraints eb
702 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
703 X.envf keep inherited
(ida
, Ast_c.MetaExprVal expb
, max_min)
705 X.distrf_e ida expb
>>= (fun ida expb
->
707 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
715 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
716 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
718 * but bug! because if have not tagged SP, then transform without doing
719 * any checks. Hopefully now have tagged SP technique.
724 * | A.Edots _, _ -> raise Impossible.
726 * In fact now can also have the Edots inside normal expression, not
727 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
729 | A.Edots
(mcode
, None
), expb
->
730 X.distrf_e
(dots2metavar mcode
) expb
>>= (fun mcode expb
->
732 A.Edots
(metavar2dots mcode
, None
) +> A.rewrap ea
,
737 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
740 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
742 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
744 ((A.Ident ida
)) +> wa,
745 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
751 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
753 (* todo?: handle some isomorphisms in int/float ? can have different
754 * format : 1l can match a 1.
756 * todo: normally string can contain some metavar too, so should
757 * recurse on the string
759 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
760 (* for everything except the String case where can have multi elems *)
762 let ib1 = tuple_of_list1 ii
in
763 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
765 ((A.Constant ia1
)) +> wa,
766 ((B.Constant
(ib
), typ),[ib1])
769 (match term ia1
, ib
with
770 | A.Int x
, B.Int
(y
,_
) ->
771 X.value_format_flag
(fun use_value_equivalence
->
772 if use_value_equivalence
782 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
784 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
787 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
790 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
792 ((A.Constant ia1
)) +> wa,
793 ((B.Constant
(ib
), typ),[ib1])
795 | _
-> fail (* multi string, not handled *)
798 | _
, B.MultiString _
-> (* todo cocci? *) fail
799 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
803 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
804 (* todo: do special case to allow IdMetaFunc, cos doing the
805 * recursive call will be too late, match_ident will not have the
806 * info whether it was a function. todo: but how detect when do
807 * x.field = f; how know that f is a Func ? By having computed
808 * some information before the matching!
810 * Allow match with FunCall containing types. Now ast_cocci allow
811 * type in parameter, and morover ast_cocci allow f(...) and those
812 * ... could match type.
814 let (ib1, ib2
) = tuple_of_list2 ii
in
815 expression ea eb
>>= (fun ea eb
->
816 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
817 tokenf ia2 ib2
>>= (fun ia2 ib2
->
818 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
819 let eas = redots
eas easundots
in
821 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
822 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
828 | A.Assignment
(ea1
, opa
, ea2
, simple
),
829 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
830 let (opbi
) = tuple_of_list1 ii
in
831 if equal_assignOp (term opa
) opb
833 expression ea1 eb1
>>= (fun ea1 eb1
->
834 expression ea2 eb2
>>= (fun ea2 eb2
->
835 tokenf opa opbi
>>= (fun opa opbi
->
837 ((A.Assignment
(ea1
, opa
, ea2
, simple
))) +> wa,
838 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
842 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
843 let (ib1, ib2
) = tuple_of_list2 ii
in
844 expression ea1 eb1
>>= (fun ea1 eb1
->
845 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
846 expression ea3 eb3
>>= (fun ea3 eb3
->
847 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
848 tokenf ia2 ib2
>>= (fun ia2 ib2
->
850 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
851 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
854 (* todo?: handle some isomorphisms here ? *)
855 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
856 let opbi = tuple_of_list1 ii
in
857 if equal_fixOp (term opa
) opb
859 expression ea eb
>>= (fun ea eb
->
860 tokenf opa
opbi >>= (fun opa
opbi ->
862 ((A.Postfix
(ea
, opa
))) +> wa,
863 ((B.Postfix
(eb
, opb
), typ),[opbi])
868 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
869 let opbi = tuple_of_list1 ii
in
870 if equal_fixOp (term opa
) opb
872 expression ea eb
>>= (fun ea eb
->
873 tokenf opa
opbi >>= (fun opa
opbi ->
875 ((A.Infix
(ea
, opa
))) +> wa,
876 ((B.Infix
(eb
, opb
), typ),[opbi])
880 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
881 let opbi = tuple_of_list1 ii
in
882 if equal_unaryOp (term opa
) opb
884 expression ea eb
>>= (fun ea eb
->
885 tokenf opa
opbi >>= (fun opa
opbi ->
887 ((A.Unary
(ea
, opa
))) +> wa,
888 ((B.Unary
(eb
, opb
), typ),[opbi])
892 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
893 let opbi = tuple_of_list1 ii
in
894 if equal_binaryOp (term opa
) opb
896 expression ea1 eb1
>>= (fun ea1 eb1
->
897 expression ea2 eb2
>>= (fun ea2 eb2
->
898 tokenf opa
opbi >>= (fun opa
opbi ->
900 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
901 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
905 | A.Nested
(ea1
, opa
, ea2
), eb
->
907 (if A.get_test_exp ea1
&& not
(Ast_c.is_test eb
) then fail
908 else expression ea1 eb
) >|+|>
910 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
911 when equal_binaryOp (term opa
) opb
->
912 let opbi = tuple_of_list1 ii
in
914 (expression ea1 eb1
>>= (fun ea1 eb1
->
915 expression ea2 eb2
>>= (fun ea2 eb2
->
916 tokenf opa
opbi >>= (fun opa
opbi ->
918 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
919 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
922 (expression ea2 eb1
>>= (fun ea2 eb1
->
923 expression ea1 eb2
>>= (fun ea1 eb2
->
924 tokenf opa
opbi >>= (fun opa
opbi ->
926 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
927 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
930 (loop eb1
>>= (fun ea1 eb1
->
931 expression ea2 eb2
>>= (fun ea2 eb2
->
932 tokenf opa
opbi >>= (fun opa
opbi ->
934 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
935 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
938 (expression ea2 eb1
>>= (fun ea2 eb1
->
939 loop eb2
>>= (fun ea1 eb2
->
940 tokenf opa
opbi >>= (fun opa
opbi ->
942 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
943 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
945 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
949 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
950 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
951 let (ib1, ib2
) = tuple_of_list2 ii
in
952 expression ea1 eb1
>>= (fun ea1 eb1
->
953 expression ea2 eb2
>>= (fun ea2 eb2
->
954 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
955 tokenf ia2 ib2
>>= (fun ia2 ib2
->
957 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
958 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
961 (* todo?: handle some isomorphisms here ? *)
962 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
963 let (ib1) = tuple_of_list1 ii
in
964 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
965 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
966 expression ea eb
>>= (fun ea eb
->
968 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
969 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
974 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
975 let (ib1) = tuple_of_list1 ii
in
976 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
977 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
978 expression ea eb
>>= (fun ea eb
->
980 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
981 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
985 (* todo?: handle some isomorphisms here ?
986 * todo?: do some iso-by-absence on cast ?
987 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
990 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
991 let (ib1, ib2
) = tuple_of_list2 ii
in
992 fullType typa typb
>>= (fun typa typb
->
993 expression ea eb
>>= (fun ea eb
->
994 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
995 tokenf ia2 ib2
>>= (fun ia2 ib2
->
997 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
998 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1001 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1002 let ib1 = tuple_of_list1 ii
in
1003 expression ea eb
>>= (fun ea eb
->
1004 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1006 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1007 ((B.SizeOfExpr
(eb
), typ),[ib1])
1010 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1011 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1012 fullType typa typb
>>= (fun typa typb
->
1013 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1014 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1015 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1017 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1018 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1022 (* todo? iso ? allow all the combinations ? *)
1023 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1024 let (ib1, ib2
) = tuple_of_list2 ii
in
1025 expression ea eb
>>= (fun ea eb
->
1026 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1027 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1029 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1030 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1033 | A.NestExpr
(exps
,None
,true), eb
->
1034 (match A.unwrap exps
with
1036 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1038 (A.NestExpr
(A.rewrap exps
(A.DOTS
[exp
]),None
,true)) +> wa,
1044 "for nestexpr, only handling the case with dots and only one exp")
1046 | A.NestExpr _
, _
->
1047 failwith
"only handling multi and no when code in a nest expr"
1049 (* only in arg lists or in define body *)
1050 | A.TypeExp _
, _
-> fail
1052 (* only in arg lists *)
1053 | A.MetaExprList _
, _
1060 | A.DisjExpr
eas, eb
->
1061 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1063 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1064 failwith
"not handling Opt/Unique/Multi on expr"
1066 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1068 (* have not a counter part in coccinelle, for the moment *)
1069 | _
, ((B.Sequence _
,_
),_
)
1070 | _
, ((B.StatementExpr _
,_
),_
)
1071 | _
, ((B.Constructor _
,_
),_
)
1076 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1077 B.RecordPtAccess
(_
, _
)|
1078 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1079 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1080 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1081 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1082 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1090 (* ------------------------------------------------------------------------- *)
1091 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1092 fun infoidb ida idb
->
1094 | B.RegularName
(s, iis) ->
1095 let iis = tuple_of_list1
iis in
1096 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1099 (B.RegularName
(s, [iis]))
1101 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1103 (* This should be moved to the Id case of ident. Metavariables
1104 should be allowed to be bound to such variables. But doing so
1105 would require implementing an appropriate distr function *)
1108 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1109 fun infoidb ida
((idb
, iib
) as ib
) ->
1110 X.all_bound
(A.get_inherited ida
) >&&>
1111 match A.unwrap ida
with
1113 if (term sa
) =$
= idb
then
1114 tokenf sa iib
>>= (fun sa iib
->
1116 ((A.Id sa
)) +> A.rewrap ida
,
1122 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1123 X.check_constraints
(ident infoidb
) constraints ib
1125 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1126 (* use drop_pos for ids so that the pos is not added a second time in
1127 the call to tokenf *)
1128 X.envf keep inherited
(A.drop_pos mida
, Ast_c.MetaIdVal
(idb
), max_min)
1130 tokenf mida iib
>>= (fun mida iib
->
1132 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1137 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1139 X.check_constraints
(ident infoidb
) constraints ib
1141 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1142 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1144 tokenf mida iib
>>= (fun mida iib
->
1146 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1151 | LocalFunction
| Function
-> is_function()
1153 failwith
"MetaFunc, need more semantic info about id"
1154 (* the following implementation could possibly be useful, if one
1155 follows the convention that a macro is always in capital letters
1156 and that a macro is not a function.
1157 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1160 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1163 X.check_constraints
(ident infoidb
) constraints ib
1165 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1166 X.envf keep inherited
1167 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1169 tokenf mida iib
>>= (fun mida iib
->
1171 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1177 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1180 | A.OptIdent _
| A.UniqueIdent _
->
1181 failwith
"not handling Opt/Unique for ident"
1185 (* ------------------------------------------------------------------------- *)
1186 and (arguments
: sequence
->
1187 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1188 fun seqstyle eas ebs
->
1190 | Unordered
-> failwith
"not handling ooo"
1192 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1193 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1195 (* because '...' can match nothing, need to take care when have
1196 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1197 * f(1,2) for instance.
1198 * So I have added special cases such as (if startxs = []) and code
1199 * in the Ecomma matching rule.
1201 * old: Must do some try, for instance when f(...,X,Y,...) have to
1202 * test the transfo for all the combinaitions and if multiple transfo
1203 * possible ? pb ? => the type is to return a expression option ? use
1204 * some combinators to help ?
1205 * update: with the tag-SP approach, no more a problem.
1208 and arguments_bis
= fun eas ebs
->
1210 | [], [] -> return ([], [])
1211 | [], eb
::ebs
-> fail
1213 X.all_bound
(A.get_inherited ea
) >&&>
1214 (match A.unwrap ea
, ebs
with
1215 | A.Edots
(mcode
, optexpr
), ys
->
1216 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
1217 if optexpr
<> None
then failwith
"not handling when in argument";
1219 (* '...' can take more or less the beginnings of the arguments *)
1220 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1221 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1224 (* allow '...', and maybe its associated ',' to match nothing.
1225 * for the associated ',' see below how we handle the EComma
1230 if mcode_contain_plus (mcodekind mcode
)
1232 (* failwith "I have no token that I could accroche myself on" *)
1233 else return (dots2metavar mcode
, [])
1235 (* subtil: we dont want the '...' to match until the
1236 * comma. cf -test pb_params_iso. We would get at
1237 * "already tagged" error.
1238 * this is because both f (... x, ...) and f (..., x, ...)
1239 * would match a f(x,3) with our "optional-comma" strategy.
1241 (match Common.last startxs
with
1244 X.distrf_args
(dots2metavar mcode
) startxs
1247 >>= (fun mcode startxs
->
1248 let mcode = metavar2dots mcode in
1249 arguments_bis
eas endxs
>>= (fun eas endxs
->
1251 (A.Edots
(mcode, optexpr
) +> A.rewrap ea
) ::eas,
1257 | A.EComma ia1
, Right ii
::ebs
->
1258 let ib1 = tuple_of_list1 ii
in
1259 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1260 arguments_bis
eas ebs
>>= (fun eas ebs
->
1262 (A.EComma ia1
+> A.rewrap ea
)::eas,
1266 | A.EComma ia1
, ebs
->
1267 (* allow ',' to maching nothing. optional comma trick *)
1268 if mcode_contain_plus (mcodekind ia1
)
1270 else arguments_bis
eas ebs
1272 | A.MetaExprList
(ida
,leninfo
,keep
,inherited
),ys
->
1273 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1274 startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
1279 if mcode_contain_plus (mcodekind ida
)
1281 (* failwith "no token that I could accroche myself on" *)
1284 (match Common.last startxs
with
1292 let startxs'
= Ast_c.unsplit_comma
startxs in
1293 let len = List.length
startxs'
in
1296 | Some
(lenname
,lenkeep
,leninherited
) ->
1297 let max_min _
= failwith
"no pos" in
1298 X.envf lenkeep leninherited
1299 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1300 | None
-> function f
-> f
()
1304 Lib_parsing_c.lin_col_by_pos
1305 (Lib_parsing_c.ii_of_args
startxs) in
1306 X.envf keep inherited
1307 (ida
, Ast_c.MetaExprListVal
startxs'
, max_min)
1310 then return (ida
, [])
1311 else X.distrf_args ida
(Ast_c.split_comma
startxs'
)
1313 >>= (fun ida
startxs ->
1314 arguments_bis
eas endxs
>>= (fun eas endxs
->
1316 (A.MetaExprList
(ida
,leninfo
,keep
,inherited
))
1317 +> A.rewrap ea
::eas,
1325 | _unwrapx
, (Left eb
)::ebs
->
1326 argument ea eb
>>= (fun ea eb
->
1327 arguments_bis
eas ebs
>>= (fun eas ebs
->
1328 return (ea
::eas, Left eb
::ebs
)
1330 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1331 | _unwrapx
, [] -> fail
1335 and argument arga argb
=
1336 X.all_bound
(A.get_inherited arga
) >&&>
1337 match A.unwrap arga
, argb
with
1339 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1341 if b
|| sopt
<> None
1343 (* failwith "the argument have a storage and ast_cocci does not have"*)
1346 (* b = false and sopt = None *)
1347 fullType tya tyb
>>= (fun tya tyb
->
1349 (A.TypeExp tya
) +> A.rewrap arga
,
1350 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1355 | A.TypeExp tya
, _
-> fail
1356 | _
, Right
(B.ArgType _
) -> fail
1358 expression arga argb
>>= (fun arga argb
->
1359 return (arga
, Left argb
)
1361 | _
, Right
(B.ArgAction y
) -> fail
1364 (* ------------------------------------------------------------------------- *)
1365 (* todo? facto code with argument ? *)
1366 and (parameters
: sequence
->
1367 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1369 fun seqstyle eas ebs
->
1371 | Unordered
-> failwith
"not handling ooo"
1373 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1374 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1378 and parameters_bis
eas ebs
=
1380 | [], [] -> return ([], [])
1381 | [], eb
::ebs
-> fail
1383 (* the management of positions is inlined into each case, because
1384 sometimes there is a Param and sometimes a ParamList *)
1385 X.all_bound
(A.get_inherited ea
) >&&>
1386 (match A.unwrap ea
, ebs
with
1387 | A.Pdots
(mcode), ys
->
1389 (* '...' can take more or less the beginnings of the arguments *)
1390 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1391 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1396 if mcode_contain_plus (mcodekind mcode)
1398 (* failwith "I have no token that I could accroche myself on"*)
1399 else return (dots2metavar mcode, [])
1401 (match Common.last
startxs with
1404 X.distrf_params
(dots2metavar mcode) startxs
1406 ) >>= (fun mcode startxs ->
1407 let mcode = metavar2dots mcode in
1408 parameters_bis
eas endxs
>>= (fun eas endxs
->
1410 (A.Pdots
(mcode) +> A.rewrap ea
) ::eas,
1416 | A.PComma ia1
, Right ii
::ebs
->
1417 let ib1 = tuple_of_list1 ii
in
1418 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1419 parameters_bis
eas ebs
>>= (fun eas ebs
->
1421 (A.PComma ia1
+> A.rewrap ea
)::eas,
1426 | A.PComma ia1
, ebs
->
1427 (* try optional comma trick *)
1428 if mcode_contain_plus (mcodekind ia1
)
1430 else parameters_bis
eas ebs
1433 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
),ys
->
1434 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
1435 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
1440 if mcode_contain_plus (mcodekind ida
)
1442 (* failwith "I have no token that I could accroche myself on" *)
1445 (match Common.last
startxs with
1453 let startxs'
= Ast_c.unsplit_comma
startxs in
1454 let len = List.length
startxs'
in
1457 Some
(lenname
,lenkeep
,leninherited
) ->
1458 let max_min _
= failwith
"no pos" in
1459 X.envf lenkeep leninherited
1460 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
1461 | None
-> function f
-> f
()
1465 Lib_parsing_c.lin_col_by_pos
1466 (Lib_parsing_c.ii_of_params
startxs) in
1467 X.envf keep inherited
1468 (ida
, Ast_c.MetaParamListVal
startxs'
, max_min)
1471 then return (ida
, [])
1472 else X.distrf_params ida
(Ast_c.split_comma
startxs'
)
1473 ) >>= (fun ida
startxs ->
1474 parameters_bis
eas endxs
>>= (fun eas endxs
->
1476 (A.MetaParamList
(ida
,leninfo
,keep
,inherited
))
1477 +> A.rewrap ea
::eas,
1485 | A.VoidParam ta
, ys
->
1486 (match eas, ebs
with
1488 let {B.p_register
=(hasreg
,iihasreg
);
1490 p_type
=tb
; } = eb
in
1492 if idbopt
=*= None
&& not hasreg
1495 | (qub
, (B.BaseType
B.Void
,_
)) ->
1496 fullType ta tb
>>= (fun ta tb
->
1498 [(A.VoidParam ta
) +> A.rewrap ea
],
1499 [Left
{B.p_register
=(hasreg
, iihasreg
);
1508 | (A.OptParam _
| A.UniqueParam _
), _
->
1509 failwith
"handling Opt/Unique for Param"
1511 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1514 | A.MetaParam
(ida
,keep
,inherited
), (Left eb
)::ebs
->
1515 (* todo: use quaopt, hasreg ? *)
1517 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1518 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1519 X.distrf_param ida eb
1520 ) >>= (fun ida eb
->
1521 parameters_bis
eas ebs
>>= (fun eas ebs
->
1523 (A.MetaParam
(ida
,keep
,inherited
))+> A.rewrap ea
::eas,
1528 | A.Param
(typa
, idaopt
), (Left eb
)::ebs
->
1529 (*this should succeed if the C code has a name, and fail otherwise*)
1530 parameter
(idaopt
, typa
) eb
>>= (fun (idaopt
, typa
) eb
->
1531 parameters_bis
eas ebs
>>= (fun eas ebs
->
1533 (A.Param
(typa
, idaopt
))+> A.rewrap ea
:: eas,
1537 | _unwrapx
, (Right y
)::ys
-> raise Impossible
1538 | _unwrapx
, [] -> fail
1544 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1545 match hasreg, idb, ii_b_s with
1546 | false, Some s, [i1] -> Left (s, [], i1)
1547 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1548 | _, None, ii -> Right ii
1549 | _ -> raise Impossible
1553 and parameter
= fun (idaopt
, typa
) paramb
->
1555 let {B.p_register
= (hasreg
,iihasreg
);
1556 p_namei
= nameidbopt
;
1557 p_type
= typb
;} = paramb
in
1559 fullType typa typb
>>= (fun typa typb
->
1560 match idaopt
, nameidbopt
with
1561 | Some ida
, Some nameidb
->
1562 (* todo: if minus on ida, should also minus the iihasreg ? *)
1563 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1566 {B.p_register
= (hasreg
, iihasreg
);
1567 p_namei
= Some
(nameidb
);
1574 {B.p_register
=(hasreg
,iihasreg
);
1580 (* why handle this case ? because of transform_proto ? we may not
1581 * have an ident in the proto.
1582 * If have some plus on ida ? do nothing about ida ?
1584 (* not anymore !!! now that julia is handling the proto.
1585 | _, Right iihasreg ->
1588 ((hasreg, None, typb), iihasreg)
1592 | Some _
, None
-> fail
1593 | None
, Some _
-> fail
1599 (* ------------------------------------------------------------------------- *)
1600 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1601 fun (mckstart
, allminus
, decla
) declb
->
1602 X.all_bound
(A.get_inherited decla
) >&&>
1603 match A.unwrap decla
, declb
with
1605 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1606 * de toutes les declarations qui sont au debut d'un fonction et
1607 * commencer le reste du match au premier statement. Alors, ca matche
1608 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1609 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1611 * When the SP want to remove the whole function, the minus is not
1612 * on the MetaDecl but on the MetaRuleElem. So there should
1613 * be no transform of MetaDecl, just matching are allowed.
1616 | A.MetaDecl
(ida
,_keep
,_inherited
), _
-> (* keep ? inherited ? *)
1617 (* todo: should not happen in transform mode *)
1618 return ((mckstart
, allminus
, decla
), declb
)
1622 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1623 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1624 (fun decla
(var
,iiptvirgb
,iisto
)->
1625 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1627 (mckstart
, allminus
, decla
),
1628 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1631 | _
, (B.DeclList
(xs
, iiptvirgb
::iifakestart
::iisto
)) ->
1632 if X.mode
=*= PatternMode
1634 xs
+> List.fold_left
(fun acc var
->
1636 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1637 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1638 (fun decla
(var
, iiptvirgb
, iisto
) ->
1640 (mckstart
, allminus
, decla
),
1641 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1645 failwith
"More that one variable in decl. Have to split to transform."
1647 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
),ii
) ->
1648 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1650 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1651 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1652 | _
-> raise Impossible
1655 then minusize_list iistob
1656 else return ((), iistob
)
1657 ) >>= (fun () iistob
->
1659 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1660 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1661 tokenf lpa lpb
>>= (fun lpa lpb
->
1662 tokenf rpa rpb
>>= (fun rpa rpb
->
1663 tokenf enda iiendb
>>= (fun enda iiendb
->
1664 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1665 let eas = redots
eas easundots
in
1668 (mckstart
, allminus
,
1669 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1670 (B.MacroDecl
((sb
,ebs
),
1671 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1674 | _
, (B.MacroDecl _
|B.DeclList _
) -> fail
1678 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1679 X.all_bound
(A.get_inherited decla
) >&&>
1680 match A.unwrap decla
, declb
with
1682 (* kind of typedef iso, we must unfold, it's for the case
1683 * T { }; that we want to match against typedef struct { } xx_t;
1685 | A.TyDecl
(tya0
, ptvirga
),
1686 ({B.v_namei
= Some
(nameidb
, None
);
1688 B.v_storage
= (B.StoTypedef
, inl
);
1693 (match A.unwrap tya0
, typb0
with
1694 | A.Type
(cv1
,tya1
), ((qu
,il
),typb1
) ->
1696 (match A.unwrap tya1
, typb1
with
1697 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1698 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1700 let (iisub
, iisbopt
, lbb
, rbb
) =
1703 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1704 (iisub
, [], lbb
, rbb
)
1707 "warning: both a typedef (%s) and struct name introduction (%s)"
1708 (Ast_c.str_of_name nameidb
) s
1710 pr2 "warning: I will consider only the typedef";
1711 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1712 (iisub
, [iisb
], lbb
, rbb
)
1715 structdef_to_struct_name
1716 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1719 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1720 (Lib_parsing_c.al_type
structnameb))), [])
1723 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1724 tokenf lba lbb
>>= (fun lba lbb
->
1725 tokenf rba rbb
>>= (fun rba rbb
->
1726 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1727 let declsa = redots
declsa undeclsa
in
1729 (match A.unwrap tya2
with
1730 | A.Type
(cv3
, tya3
) ->
1731 (match A.unwrap tya3
with
1732 | A.MetaType
(ida
,keep
, inherited
) ->
1734 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1736 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1737 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1740 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1741 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1742 let typb0 = ((qu
, il
), typb1) in
1744 match fake_typeb with
1745 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1748 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1749 (({B.v_namei
= Some
(nameidb
, None
);
1751 B.v_storage
= (B.StoTypedef
, inl
);
1755 iivirg
),iiptvirgb
,iistob
)
1757 | _
-> raise Impossible
1760 | A.StructUnionName
(sua
, sa
) ->
1762 fullType tya2
structnameb >>= (fun tya2
structnameb ->
1764 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
1766 let tya0 = A.Type
(cv1
, tya1) +> A.rewrap
tya0 in
1768 match structnameb with
1769 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
1771 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1772 [iisub
;iisbopt
;lbb
;rbb
] in
1773 let typb0 = ((qu
, il
), typb1) in
1776 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1777 (({B.v_namei
= Some
(nameidb
, None
);
1779 B.v_storage
= (B.StoTypedef
, inl
);
1783 iivirg
),iiptvirgb
,iistob
)
1785 | _
-> raise Impossible
1787 | _
-> raise Impossible
1796 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1797 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
1800 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1801 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
1806 (* could handle iso here but handled in standard.iso *)
1807 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
1808 ({B.v_namei
= Some
(nameidb
, None
);
1815 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1816 fullType typa typb
>>= (fun typa typb
->
1817 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1818 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1819 (fun stoa
(stob
, iistob
) ->
1821 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1822 (({B.v_namei
= Some
(nameidb
, None
);
1831 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
1832 ({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1839 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1840 tokenf eqa iieqb
>>= (fun eqa iieqb
->
1841 fullType typa typb
>>= (fun typa typb
->
1842 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1843 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
1844 (fun stoa
(stob
, iistob
) ->
1845 initialiser inia inib
>>= (fun inia inib
->
1847 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
1848 (({B.v_namei
= Some
(nameidb
, Some
(iieqb
, inib
));
1857 (* do iso-by-absence here ? allow typedecl and var ? *)
1858 | A.TyDecl
(typa
, ptvirga
),
1859 ({B.v_namei
= None
; B.v_type
= typb
;
1865 if stob
=*= (B.NoSto
, false)
1867 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1868 fullType typa typb
>>= (fun typa typb
->
1870 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
1871 (({B.v_namei
= None
;
1876 }, iivirg
), iiptvirgb
, iistob
)
1881 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
1882 ({B.v_namei
= Some
(nameidb
, None
);
1884 B.v_storage
= (B.StoTypedef
,inline
);
1889 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1890 fullType typa typb
>>= (fun typa typb
->
1893 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
1894 return (stoa
, [iitypedef
])
1896 | _
-> failwith
"weird, have both typedef and inline or nothing";
1897 ) >>= (fun stoa iistob
->
1898 (match A.unwrap ida
with
1899 | A.MetaType
(_
,_
,_
) ->
1902 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
1904 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
1905 match fake_typeb with
1906 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
1907 return (ida
, nameidb
)
1908 | _
-> raise Impossible
1913 | B.RegularName
(sb
, iidb
) ->
1914 let iidb1 = tuple_of_list1 iidb
in
1918 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
1920 (A.TypeName sa
) +> A.rewrap ida
,
1921 B.RegularName
(sb
, [iidb1])
1925 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1929 | _
-> raise Impossible
1931 ) >>= (fun ida nameidb
->
1933 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
1934 (({B.v_namei
= Some
(nameidb
, None
);
1936 B.v_storage
= (B.StoTypedef
,inline
);
1946 | _
, ({B.v_namei
= None
;}, _
) ->
1947 (* old: failwith "no variable in this declaration, weird" *)
1952 | A.DisjDecl declas
, declb
->
1953 declas
+> List.fold_left
(fun acc decla
->
1955 (* (declaration (mckstart, allminus, decla) declb) *)
1956 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
1961 (* only in struct type decls *)
1962 | A.Ddots
(dots
,whencode
), _
->
1965 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
1966 failwith
"not handling Opt/Unique Decl"
1968 | _
, ({B.v_namei
=Some _
}, _
) ->
1974 (* ------------------------------------------------------------------------- *)
1976 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
1977 X.all_bound
(A.get_inherited ia
) >&&>
1978 match (A.unwrap ia
,ib
) with
1980 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
1982 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
1983 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
1985 X.distrf_ini ida ib
>>= (fun ida ib
->
1987 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
1992 | (A.InitExpr expa
, ib
) ->
1993 (match A.unwrap expa
, ib
with
1994 | A.Edots
(mcode, None
), ib
->
1995 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
1998 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2003 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2005 | _
, (B.InitExpr expb
, ii
) ->
2007 expression expa expb
>>= (fun expa expb
->
2009 (A.InitExpr expa
) +> A.rewrap ia
,
2010 (B.InitExpr expb
, ii
)
2015 | (A.InitList
(ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2017 | ib1::ib2
::iicommaopt
->
2018 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2019 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2020 initialisers ias
(ibs
, iicommaopt
) >>= (fun ias
(ibs
,iicommaopt
) ->
2022 (A.InitList
(ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2023 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2026 | _
-> raise Impossible
2029 | (A.InitList
(i1
, ias
, i2
, whencode
),(B.InitList ibs
, _ii
)) ->
2030 failwith
"TODO: not handling whencode in initialisers"
2033 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2034 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2036 let iieq = tuple_of_list1 ii2
in
2038 tokenf ia2
iieq >>= (fun ia2
iieq ->
2039 designators designatorsa designatorsb
>>=
2040 (fun designatorsa designatorsb
->
2041 initialiser inia inib
>>= (fun inia inib
->
2043 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2044 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2050 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2053 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2054 initialiser inia inib
>>= (fun inia inib
->
2055 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2057 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2058 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2065 | A.IComma
(comma
), _
->
2068 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2069 failwith
"not handling Opt/Unique on initialisers"
2071 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2072 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2074 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2077 and designators dla dlb
=
2078 match (dla
,dlb
) with
2079 ([],[]) -> return ([], [])
2080 | ([],_
) | (_
,[]) -> fail
2081 | (da
::dla
,db
::dlb
) ->
2082 designator da db
>>= (fun da db
->
2083 designators dla dlb
>>= (fun dla dlb
->
2084 return (da
::dla
, db
::dlb
)))
2086 and designator da db
=
2088 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2090 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2091 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2092 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2094 A.DesignatorField
(ia1
, ida
),
2095 (B.DesignatorField idb
, [iidot
;iidb
])
2098 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2100 let (ib1, ib2
) = tuple_of_list2 ii1
in
2101 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2102 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2103 expression ea eb
>>= (fun ea eb
->
2105 A.DesignatorIndex
(ia1
,ea
,ia2
),
2106 (B.DesignatorIndex eb
, [ib1;ib2
])
2109 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2110 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2112 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2113 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2114 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2115 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2116 expression e1a e1b
>>= (fun e1a e1b
->
2117 expression e2a e2b
>>= (fun e2a e2b
->
2119 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2120 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2122 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2126 and initialisers
= fun ias
(ibs
, iicomma
) ->
2127 let ias_unsplit = unsplit_icomma ias
in
2128 let ibs_split = resplit_initialiser ibs iicomma
in
2131 if need_unordered_initialisers ibs
2132 then initialisers_unordered2
2133 else initialisers_ordered2
2135 f ias_unsplit ibs_split >>=
2136 (fun ias_unsplit ibs_split ->
2138 split_icomma ias_unsplit,
2139 unsplit_initialiser ibs_split
2143 (* todo: one day julia will reput a IDots *)
2144 and initialisers_ordered2
= fun ias ibs
->
2146 | [], [] -> return ([], [])
2147 | (x
, xcomma
)::xs
, (y
, commay
)::ys
->
2148 (match A.unwrap xcomma
with
2149 | A.IComma commax
->
2150 tokenf commax commay
>>= (fun commax commay
->
2151 initialiser x y
>>= (fun x y
->
2152 initialisers_ordered2 xs ys
>>= (fun xs ys
->
2154 (x
, (A.IComma commax
) +> A.rewrap xcomma
)::xs
,
2158 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2164 and initialisers_unordered2
= fun ias ibs
->
2167 | [], ys
-> return ([], ys
)
2168 | (x
,xcomma
)::xs
, ys
->
2170 let permut = Common.uncons_permut_lazy ys
in
2171 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2174 (match A.unwrap xcomma
, e
with
2175 | A.IComma commax
, (y
, commay
) ->
2176 tokenf commax commay
>>= (fun commax commay
->
2177 initialiser x y
>>= (fun x y
->
2179 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2183 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2186 let rest = Lazy.force
rest in
2187 initialisers_unordered2 xs
rest >>= (fun xs
rest ->
2190 Common.insert_elem_pos
(e
, pos
) rest
2195 (* ------------------------------------------------------------------------- *)
2196 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2199 | [], [] -> return ([], [])
2200 | [], eb
::ebs
-> fail
2202 X.all_bound
(A.get_inherited ea
) >&&>
2203 (match A.unwrap ea
, ebs
with
2204 | A.Ddots
(mcode, optwhen
), ys
->
2205 if optwhen
<> None
then failwith
"not handling when in argument";
2207 (* '...' can take more or less the beginnings of the arguments *)
2208 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
2209 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
2214 if mcode_contain_plus (mcodekind mcode)
2216 (* failwith "I have no token that I could accroche myself on" *)
2217 else return (dots2metavar mcode, [])
2220 X.distrf_struct_fields
(dots2metavar mcode) startxs
2221 ) >>= (fun mcode startxs ->
2222 let mcode = metavar2dots mcode in
2223 struct_fields
eas endxs
>>= (fun eas endxs
->
2225 (A.Ddots
(mcode, optwhen
) +> A.rewrap ea
) ::eas,
2230 | _unwrapx
, eb
::ebs
->
2231 struct_field ea eb
>>= (fun ea eb
->
2232 struct_fields
eas ebs
>>= (fun eas ebs
->
2233 return (ea
::eas, eb
::ebs
)
2236 | _unwrapx
, [] -> fail
2239 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2242 | B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2244 let iiptvirgb = tuple_of_list1 iiptvirg
in
2246 (match onefield_multivars
with
2247 | [] -> raise Impossible
2248 | [onevar
,iivirg
] ->
2249 assert (null iivirg
);
2251 | B.BitField
(sopt
, typb
, _
, expr
) ->
2252 pr2_once
"warning: bitfield not handled by ast_cocci";
2254 | B.Simple
(None
, typb
) ->
2255 pr2_once
"warning: unamed struct field not handled by ast_cocci";
2257 | B.Simple
(Some nameidb
, typb
) ->
2259 (* build a declaration from a struct field *)
2260 let allminus = false in
2262 let stob = B.NoSto
, false in
2264 ({B.v_namei
= Some
(nameidb
, None
);
2267 B.v_local
= Ast_c.NotLocalDecl
;
2268 B.v_attr
= Ast_c.noattr
;
2272 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2273 (fun fa
(var
,iiptvirgb,iisto) ->
2276 | ({B.v_namei
= Some
(nameidb
, None
);
2281 let onevar = B.Simple
(Some nameidb
, typb
) in
2285 ((B.DeclarationField
2286 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2289 | _
-> raise Impossible
2294 pr2_once
"PB: More that one variable in decl. Have to split";
2297 | B.EmptyField _iifield
->
2300 | B.MacroDeclField _
->
2303 | B.CppDirectiveStruct directive
-> fail
2304 | B.IfdefStruct directive
-> fail
2308 (* ------------------------------------------------------------------------- *)
2309 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2311 X.optional_qualifier_flag
(fun optional_qualifier
->
2312 X.all_bound
(A.get_inherited typa
) >&&>
2313 match A.unwrap typa
, typb
with
2314 | A.Type
(cv
,ty1
), ((qu
,il
),ty2
) ->
2316 if qu
.B.const
&& qu
.B.volatile
2319 ("warning: the type is both const & volatile but cocci " ^
2320 "does not handle that");
2322 (* Drop out the const/volatile part that has been matched.
2323 * This is because a SP can contain const T v; in which case
2324 * later in match_t_t when we encounter a T, we must not add in
2325 * the environment the whole type.
2330 (* "iso-by-absence" *)
2333 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1 fullty2
->
2335 (A.Type
(None
, ty1
)) +> A.rewrap typa
,
2339 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2340 | false, false -> do_stuff ()
2341 | false, true -> fail
2342 | true, false -> do_stuff ()
2345 then pr2_once
"USING optional_qualifier builtin isomorphism";
2351 (* todo: can be __const__ ? can be const & volatile so
2352 * should filter instead ?
2354 (match term x
, il
with
2355 | A.Const
, [i1
] when qu
.B.const
->
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
,
2364 | A.Volatile
, [i1
] when qu
.B.volatile
->
2365 tokenf x i1
>>= (fun x i1
->
2366 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2368 (A.Type
(Some x
, ty1
)) +> A.rewrap typa
,
2376 | A.DisjType typas
, typb
->
2378 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2380 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2381 -> failwith
"not handling Opt/Unique on type"
2386 * Why not (A.typeC, Ast_c.typeC) matcher ?
2387 * because when there is MetaType, we want that T record the whole type,
2388 * including the qualifier, and so this type (and the new_il function in
2389 * preceding function).
2392 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2394 X.all_bound
(A.get_inherited ta
) >&&>
2395 match A.unwrap ta
, tb
with
2398 | A.MetaType
(ida
,keep
, inherited
), typb
->
2400 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2401 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2402 X.distrf_type ida typb
>>= (fun ida typb
->
2404 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2408 | unwrap
, (qub
, typb
) ->
2409 typeC ta typb
>>= (fun ta typb
->
2410 return (ta
, (qub
, typb
))
2413 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2414 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2415 * And even if in baseb we have a Signed Int, that does not mean
2416 * that ii is of length 2, cos Signed is the default, so if in signa
2417 * we have Signed explicitely ? we cant "accrocher" this mcode to
2418 * something :( So for the moment when there is signed in cocci,
2419 * we force that there is a signed in c too (done in pattern.ml).
2421 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2424 (* handle some iso on type ? (cf complex C rule for possible implicit
2426 match basea
, baseb
with
2427 | A.VoidType
, B.Void
2428 | A.FloatType
, B.FloatType
(B.CFloat
)
2429 | A.DoubleType
, B.FloatType
(B.CDouble
) ->
2430 assert (signaopt
=*= None
);
2431 let stringa = tuple_of_list1 stringsa
in
2432 let (ibaseb
) = tuple_of_list1 ii
in
2433 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2435 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2436 (B.BaseType baseb
, [ibaseb
])
2439 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2440 let stringa = tuple_of_list1 stringsa
in
2441 let ibaseb = tuple_of_list1 ii
in
2442 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2444 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2445 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2448 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2449 let stringa = tuple_of_list1 stringsa
in
2450 let ibaseb = tuple_of_list1 iibaseb
in
2451 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2452 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2454 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2455 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2458 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2459 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2460 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2461 let stringa = tuple_of_list1 stringsa
in
2464 (* iso-by-presence ? *)
2465 (* when unsigned int in SP, allow have just unsigned in C ? *)
2466 if mcode_contain_plus (mcodekind stringa)
2470 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2472 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2473 (B.BaseType
(baseb
), iisignbopt
++ [])
2479 "warning: long int or short int not handled by ast_cocci";
2483 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2484 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2486 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2487 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2489 | _
-> raise Impossible
2494 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2495 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2497 [ibase1b
;ibase2b
] ->
2498 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2499 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2500 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2502 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2503 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2505 | [] -> fail (* should something be done in this case? *)
2506 | _
-> raise Impossible
)
2509 | _
, B.FloatType
B.CLongDouble
2512 "warning: long double not handled by ast_cocci";
2515 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2517 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2518 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2519 * And even if in baseb we have a Signed Int, that does not mean
2520 * that ii is of length 2, cos Signed is the default, so if in signa
2521 * we have Signed explicitely ? we cant "accrocher" this mcode to
2522 * something :( So for the moment when there is signed in cocci,
2523 * we force that there is a signed in c too (done in pattern.ml).
2525 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2527 let match_to_type rebaseb
=
2528 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2529 let fta = A.rewrap basea
(A.Type
(None
,basea
)) in
2530 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2531 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2532 (match A.unwrap
fta,tb
with
2533 A.Type
(_
,basea
), (B.BaseType baseb
, ii
) ->
2535 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2536 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2538 | _
-> failwith
"not possible"))) in
2540 (* handle some iso on type ? (cf complex C rule for possible implicit
2543 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2544 match_to_type (B.IntType
B.CChar
)
2546 | B.IntType
(B.Si
(_
, ty
)) ->
2548 | [] -> fail (* metavariable has to match something *)
2550 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2554 | (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2556 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2558 match A.unwrap ta
, tb
with
2559 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2560 simulate_signed ta basea stringsa None tb baseb ii
2561 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2562 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2563 (match A.unwrap basea
with
2564 A.BaseType
(basea1
,strings1
) ->
2565 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2566 (function (strings1
, Some signaopt
) ->
2569 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2570 | _
-> failwith
"not possible")
2571 | A.MetaType
(ida
,keep
,inherited
) ->
2572 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2573 (function (basea
, Some signaopt
) ->
2574 A.SignedT
(signaopt
,Some basea
)
2575 | _
-> failwith
"not possible")
2576 | _
-> failwith
"not possible")
2577 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2578 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2579 (match iibaseb
, baseb
with
2580 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2581 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2583 | None
-> raise Impossible
2586 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2587 (B.BaseType baseb
, iisignbopt
)
2595 (* todo? iso with array *)
2596 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2597 let (ibmult
) = tuple_of_list1 ii
in
2598 fullType typa typb
>>= (fun typa typb
->
2599 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2601 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2602 (B.Pointer typb
, [ibmult
])
2605 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2606 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2608 let (lpb
, rpb
) = tuple_of_list2 ii
in
2612 ("Not handling well variable length arguments func. "^
2613 "You have been warned");
2614 tokenf lpa lpb
>>= (fun lpa lpb
->
2615 tokenf rpa rpb
>>= (fun rpa rpb
->
2616 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
2617 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
2618 (fun paramsaundots paramsb
->
2619 let paramsa = redots
paramsa paramsaundots
in
2621 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
2622 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
2630 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
2631 (B.ParenType t1
, ii
) ->
2632 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
2633 let (qu1b
, t1b
) = t1
in
2635 | B.Pointer t2
, ii
->
2636 let (starb
) = tuple_of_list1 ii
in
2637 let (qu2b
, t2b
) = t2
in
2639 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
2640 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
2645 ("Not handling well variable length arguments func. "^
2646 "You have been warned");
2648 fullType tya tyb
>>= (fun tya tyb
->
2649 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
2650 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
2651 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
2652 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
2653 tokenf stara starb
>>= (fun stara starb
->
2654 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
2655 (fun paramsaundots paramsb
->
2656 let paramsa = redots
paramsa paramsaundots
in
2660 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
2665 (B.Pointer
t2, [starb
]))
2669 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
2671 (B.ParenType
t1, [lp1b
;rp1b
])
2684 (* todo: handle the iso on optionnal size specifification ? *)
2685 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
2686 let (ib1, ib2
) = tuple_of_list2 ii
in
2687 fullType typa typb
>>= (fun typa typb
->
2688 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
2689 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2690 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2692 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
2693 (B.Array
(ebopt
, typb
), [ib1;ib2
])
2697 (* todo: could also match a Struct that has provided a name *)
2698 (* This is for the case where the SmPL code contains "struct x", without
2699 a definition. In this case, the name field is always present.
2700 This case is also called from the case for A.StructUnionDef when
2701 a name is present in the C code. *)
2702 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
2703 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
2704 let (ib1, ib2
) = tuple_of_list2 ii
in
2705 if equal_structUnion (term sua
) sub
2707 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
2708 tokenf sua
ib1 >>= (fun sua
ib1 ->
2710 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
2711 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
2716 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
2717 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2719 let (ii_sub_sb
, lbb
, rbb
) =
2721 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
2722 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
2723 | _
-> failwith
"list of length 3 or 4 expected" in
2726 match (sbopt
,ii_sub_sb
) with
2727 (None
,Common.Left iisub
) ->
2728 (* the following doesn't reconstruct the complete SP code, just
2729 the part that matched *)
2731 match A.unwrap
s with
2733 (match A.unwrap ty
with
2734 A.StructUnionName
(sua
, None
) ->
2735 tokenf sua iisub
>>= (fun sua iisub
->
2738 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
2740 return (ty,[iisub
]))
2742 | A.DisjType
(disjs
) ->
2744 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
2748 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
2750 (* build a StructUnionName from a StructUnion *)
2751 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
2753 fullType
ty fake_su >>= (fun ty fake_su ->
2755 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
2756 return (ty, [iisub
; iisb
])
2757 | _
-> raise Impossible
)
2761 >>= (fun ty ii_sub_sb
->
2763 tokenf lba lbb
>>= (fun lba lbb
->
2764 tokenf rba rbb
>>= (fun rba rbb
->
2765 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
2766 let declsa = redots
declsa undeclsa
in
2769 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
2770 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
2774 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
2775 * uint in the C code. But some CEs consists in renaming some types,
2776 * so we don't want apply isomorphisms every time.
2778 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
2782 | B.RegularName
(sb
, iidb
) ->
2783 let iidb1 = tuple_of_list1 iidb
in
2787 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2789 (A.TypeName sa
) +> A.rewrap ta
,
2790 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
2794 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2799 | _
, (B.TypeOfExpr e
, ii
) -> fail
2800 | _
, (B.TypeOfType e
, ii
) -> fail
2802 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
2803 | A.EnumName
(en
,namea
), (B.EnumName nameb
, ii
) ->
2804 let (ib1,ib2
) = tuple_of_list2 ii
in
2805 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
2806 tokenf en
ib1 >>= (fun en
ib1 ->
2808 (A.EnumName
(en
, namea
)) +> A.rewrap ta
,
2809 (B.EnumName nameb
, [ib1;ib2
])
2812 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
2815 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
2816 B.StructUnion
(_
, _
, _
) |
2817 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
2823 (* todo: iso on sign, if not mentioned then free. tochange?
2824 * but that require to know if signed int because explicit
2825 * signed int, or because implicit signed int.
2828 and sign signa signb
=
2829 match signa
, signb
with
2830 | None
, None
-> return (None
, [])
2831 | Some signa
, Some
(signb
, ib
) ->
2832 if equal_sign (term signa
) signb
2833 then tokenf signa ib
>>= (fun signa ib
->
2834 return (Some signa
, [ib
])
2840 and minusize_list iixs
=
2841 iixs
+> List.fold_left
(fun acc ii
->
2842 acc
>>= (fun xs ys
->
2843 tokenf minusizer ii
>>= (fun minus ii
->
2844 return (minus
::xs
, ii
::ys
)
2845 ))) (return ([],[]))
2846 >>= (fun _xsminys ys
->
2847 return ((), List.rev ys
)
2850 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
2851 (* "iso-by-absence" for storage, and return type. *)
2852 X.optional_storage_flag
(fun optional_storage
->
2853 match stoa
, stob with
2854 | None
, (stobis
, inline
) ->
2858 minusize_list iistob
>>= (fun () iistob
->
2859 return (None
, (stob, iistob
))
2861 else return (None
, (stob, iistob
))
2864 (match optional_storage
, stobis
with
2865 | false, B.NoSto
-> do_minus ()
2867 | true, B.NoSto
-> do_minus ()
2870 then pr2_once
"USING optional_storage builtin isomorphism";
2874 | Some x
, ((stobis
, inline
)) ->
2875 if equal_storage (term x
) stobis
2879 tokenf x i1
>>= (fun x i1
->
2880 return (Some x
, ((stobis
, inline
), [i1
]))
2882 (* or if have inline ? have to do a split_storage_inline a la
2883 * split_signb_baseb_ii *)
2884 | _
-> raise Impossible
2892 and fullType_optional_allminus
allminus tya retb
=
2897 X.distrf_type
minusizer retb
>>= (fun _x retb
->
2901 else return (None
, retb
)
2903 fullType tya retb
>>= (fun tya retb
->
2904 return (Some tya
, retb
)
2909 (*---------------------------------------------------------------------------*)
2911 and compatible_base_type a signa b
=
2912 let ok = return ((),()) in
2915 | Type_cocci.VoidType
, B.Void
->
2916 assert (signa
=*= None
);
2918 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
2920 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2921 compatible_sign signa signb
2922 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
2923 compatible_sign signa signb
2924 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
2925 compatible_sign signa signb
2926 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
2927 compatible_sign signa signb
2928 | _
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
2929 pr2_once
"no longlong in cocci";
2931 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
2932 assert (signa
=*= None
);
2934 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
2935 assert (signa
=*= None
);
2937 | _
, B.FloatType
B.CLongDouble
->
2938 pr2_once
"no longdouble in cocci";
2940 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
2942 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2944 and compatible_base_type_meta a signa qua b ii
local =
2946 | Type_cocci.MetaType
(ida
,keep
,inherited
),
2947 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
2948 compatible_sign signa signb
>>= fun _ _
->
2949 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
2950 compatible_type a
newb
2951 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
2952 compatible_sign signa signb
>>= fun _ _
->
2954 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
2955 compatible_type a
newb
2956 | _
, B.FloatType
B.CLongDouble
->
2957 pr2_once
"no longdouble in cocci";
2960 | _
, (B.Void
|B.FloatType _
|B.IntType _
) -> fail
2963 and compatible_type a
(b
,local) =
2964 let ok = return ((),()) in
2966 let rec loop = function
2967 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
2968 compatible_base_type a None b
2970 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
2971 compatible_base_type
Type_cocci.IntType
(Some signa
) b
2973 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
2975 Type_cocci.BaseType
ty ->
2976 compatible_base_type
ty (Some signa
) b
2977 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
2978 compatible_base_type_meta
ty (Some signa
) qua b ii
local
2979 | _
-> failwith
"not possible")
2981 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
2983 | Type_cocci.FunctionPointer a
, _
->
2985 "TODO: function pointer type doesn't store enough information to determine compatability"
2986 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
2987 (* no size info for cocci *)
2989 | Type_cocci.StructUnionName
(sua
, _
, sa
),
2990 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
2991 if equal_structUnion_type_cocci sua sub
&& sa
=$
= sb
2994 | Type_cocci.EnumName
(_
, sa
),
2995 (qub
, (B.EnumName
(sb
),ii
)) ->
2999 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3000 let sb = Ast_c.str_of_name namesb
in
3005 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3006 if (fst qub
).B.const
&& (fst qub
).B.volatile
3009 pr2_once
("warning: the type is both const & volatile but cocci " ^
3010 "does not handle that");
3016 | Type_cocci.Const
-> (fst qub
).B.const
3017 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3019 then loop (a
,(Ast_c.nQ
, b
))
3022 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3024 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3025 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3029 (* subtil: must be after the MetaType case *)
3030 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3031 (* kind of typedef iso *)
3038 (* for metavariables of type expression *^* *)
3039 | Type_cocci.Unknown
, _
-> ok
3044 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3045 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3052 B.StructUnionName
(_
, _
)|
3054 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3063 and compatible_sign signa signb
=
3064 let ok = return ((),()) in
3065 match signa
, signb
with
3067 | Some
Type_cocci.Signed
, B.Signed
3068 | Some
Type_cocci.Unsigned
, B.UnSigned
3073 and equal_structUnion_type_cocci a b
=
3075 | Type_cocci.Struct
, B.Struct
-> true
3076 | Type_cocci.Union
, B.Union
-> true
3077 | _
, (B.Struct
| B.Union
) -> false
3081 (*---------------------------------------------------------------------------*)
3082 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3084 let rec aux_inc (ass
, bss
) passed
=
3088 let passed = List.rev
passed in
3090 (match before_after
, !h_rel_pos
with
3091 | IncludeNothing
, _
-> true
3092 | IncludeMcodeBefore
, Some x
->
3093 List.mem
passed (x
.Ast_c.first_of
)
3095 | IncludeMcodeAfter
, Some x
->
3096 List.mem
passed (x
.Ast_c.last_of
)
3098 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3102 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3103 | _
-> failwith
"IncDots not in last place or other pb"
3108 | A.Local ass
, B.Local bss
->
3109 aux_inc (ass
, bss
) []
3110 | A.NonLocal ass
, B.NonLocal bss
->
3111 aux_inc (ass
, bss
) []
3116 (*---------------------------------------------------------------------------*)
3118 and (define_params
: sequence
->
3119 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3120 fun seqstyle eas ebs
->
3122 | Unordered
-> failwith
"not handling ooo"
3124 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3125 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3128 (* todo? facto code with argument and parameters ? *)
3129 and define_paramsbis
= fun eas ebs
->
3131 | [], [] -> return ([], [])
3132 | [], eb
::ebs
-> fail
3134 X.all_bound
(A.get_inherited ea
) >&&>
3135 (match A.unwrap ea
, ebs
with
3136 | A.DPdots
(mcode), ys
->
3138 (* '...' can take more or less the beginnings of the arguments *)
3139 let startendxs = Common.zip
(Common.inits ys
) (Common.tails ys
) in
3140 startendxs +> List.fold_left
(fun acc
(startxs, endxs
) ->
3145 if mcode_contain_plus (mcodekind mcode)
3147 (* failwith "I have no token that I could accroche myself on" *)
3148 else return (dots2metavar mcode, [])
3150 (match Common.last
startxs with
3153 X.distrf_define_params
(dots2metavar mcode) startxs
3155 ) >>= (fun mcode startxs ->
3156 let mcode = metavar2dots mcode in
3157 define_paramsbis
eas endxs
>>= (fun eas endxs
->
3159 (A.DPdots
(mcode) +> A.rewrap ea
) ::eas,
3165 | A.DPComma ia1
, Right ii
::ebs
->
3166 let ib1 = tuple_of_list1 ii
in
3167 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3168 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3170 (A.DPComma ia1
+> A.rewrap ea
)::eas,
3175 | A.DPComma ia1
, ebs
->
3176 if mcode_contain_plus (mcodekind ia1
)
3179 (define_paramsbis
eas ebs
) (* try optional comma trick *)
3181 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3182 failwith
"handling Opt/Unique for define parameters"
3184 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3186 | A.DParam ida
, (Left
(idb
, ii
))::ebs
->
3187 let ib1 = tuple_of_list1 ii
in
3188 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3189 define_paramsbis
eas ebs
>>= (fun eas ebs
->
3191 (A.DParam ida
)+> A.rewrap ea
:: eas,
3192 (Left
(idb
, [ib1]))::ebs
3195 | _unwrapx
, (Right y
)::ys
-> raise Impossible
3196 | _unwrapx
, [] -> fail
3201 (*****************************************************************************)
3203 (*****************************************************************************)
3205 (* no global solution for positions here, because for a statement metavariable
3206 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3208 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3211 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3213 X.all_bound
(A.get_inherited re
) >&&>
3216 match A.unwrap re
, F.unwrap node
with
3218 (* note: the order of the clauses is important. *)
3220 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3222 (* the metaRuleElem contains just '-' information. We dont need to add
3223 * stuff in the environment. If we need stuff in environment, because
3224 * there is a + S somewhere, then this will be done via MetaStmt, not
3226 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3229 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3230 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3231 (match unwrap_node
with
3233 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
3235 if X.mode
=*= PatternMode
3238 if mcode_contain_plus (mcodekind mcode)
3239 then failwith
"try add stuff on fake node"
3240 (* minusize or contextize a fake node is ok *)
3243 | F.EndStatement None
->
3244 if X.mode
=*= PatternMode
then return default
3246 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3247 if mcode_contain_plus (mcodekind mcode)
3249 let fake_info = Ast_c.fakeInfo() in
3250 distrf distrf_node (mcodekind mcode)
3251 (F.EndStatement (Some fake_info))
3252 else return unwrap_node
3256 | F.EndStatement
(Some i1
) ->
3257 tokenf mcode i1
>>= (fun mcode i1
->
3259 A.MetaRuleElem
(mcode,keep
, inherited
),
3260 F.EndStatement
(Some i1
)
3264 if X.mode
=*= PatternMode
then return default
3265 else failwith
"a MetaRuleElem can't transform a headfunc"
3267 if X.mode
=*= PatternMode
then return default
3269 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3271 A.MetaRuleElem
(mcode,keep
, inherited
),
3277 (* rene cant have found that a state containing a fake/exit/... should be
3279 * TODO: and F.Fake ?
3281 | _
, F.EndStatement _
| _
, F.CaseNode _
3282 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
| _
, F.FallThroughNode
3286 (* really ? diff between pattern.ml and transformation.ml *)
3287 | _
, F.Fake
-> fail2()
3290 (* cas general: a Meta can match everything. It matches only
3291 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3292 * So can't have been called in transform.
3294 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3296 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3297 (* todo: should not happen in transform mode *)
3299 (match Control_flow_c.extract_fullstatement node
with
3302 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3303 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3305 (* no need tag ida, we can't be called in transform-mode *)
3307 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3315 | A.MetaStmtList _
, _
->
3316 failwith
"not handling MetaStmtList"
3318 | A.TopExp ea
, F.DefineExpr eb
->
3319 expression ea eb
>>= (fun ea eb
->
3325 | A.TopExp ea
, F.DefineType eb
->
3326 (match A.unwrap ea
with
3328 fullType ft eb
>>= (fun ft eb
->
3330 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3337 (* It is important to put this case before the one that fails because
3338 * of the lack of the counter part of a C construct in SmPL (for instance
3339 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3340 * yet certain constructs, those constructs may contain expression
3341 * that we still want and can transform.
3344 | A.Exp exp
, nodeb
->
3346 (* kind of iso, initialisation vs affectation *)
3348 match A.unwrap exp
, nodeb
with
3349 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3350 initialisation_to_affectation decl
+> F.rewrap node
3355 (* Now keep fullstatement inside the control flow node,
3356 * so that can then get in a MetaStmtVar the fullstatement to later
3357 * pp back when the S is in a +. But that means that
3358 * Exp will match an Ifnode even if there is no such exp
3359 * inside the condition of the Ifnode (because the exp may
3360 * be deeper, in the then branch). So have to not visit
3361 * all inside a node anymore.
3363 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3364 * fois le fullstatement et le partialstatement et appeler le
3365 * visiteur que sur le partialstatement.
3368 match Ast_cocci.get_pos re
with
3369 | None
-> expression
3373 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3374 let keep = Type_cocci.Unitary
in
3375 let inherited = false in
3376 let max_min _
= failwith
"no pos" in
3377 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3383 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3391 X.cocciTy fullType
ty node >>= (fun ty node ->
3398 | A.TopInit init
, nodeb
->
3399 X.cocciInit initialiser init
node >>= (fun init
node ->
3407 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3408 F.FunHeader
({B.f_name
= nameidb
;
3409 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3413 f_old_c_style
= oldstyle
;
3418 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3421 (* fninfoa records the order in which the SP specified the various
3422 information, but this isn't taken into account in the matching.
3423 Could this be a problem for transformation? *)
3426 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3427 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3429 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3430 with [A.FType
(t
)] -> Some t
| _
-> None
in
3432 (match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3433 with [A.FInline
(i
)] -> failwith
"not checking inline" | _
-> ());
3435 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3436 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3439 | ioparenb
::icparenb
::iifakestart
::iistob
->
3441 (* maybe important to put ident as the first tokens to transform.
3442 * It's related to transform_proto. So don't change order
3445 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3446 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3447 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3448 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3449 parameters
(seqstyle paramsa)
3450 (A.undots
paramsa) paramsb
>>=
3451 (fun paramsaundots paramsb
->
3452 let paramsa = redots
paramsa paramsaundots
in
3453 storage_optional_allminus
allminus
3454 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3459 ("Not handling well variable length arguments func. "^
3460 "You have been warned");
3462 then minusize_list iidotsb
3463 else return ((),iidotsb
)
3464 ) >>= (fun () iidotsb
->
3466 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3469 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3470 (match tya with Some t
-> [A.FType t
] | None
-> [])
3475 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3477 F.FunHeader
({B.f_name
= nameidb
;
3478 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3482 f_old_c_style
= oldstyle
; (* TODO *)
3484 ioparenb
::icparenb
::iifakestart
::iistob
)
3487 | _
-> raise Impossible
3495 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3496 declaration
(mckstart
,allminus,decla
) declb
>>=
3497 (fun (mckstart
,allminus,decla
) declb
->
3499 A.Decl
(mckstart
,allminus,decla
),
3504 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3505 tokenf mcode i1
>>= (fun mcode i1
->
3508 F.SeqStart
(st
, level
, i1
)
3511 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3512 tokenf mcode i1
>>= (fun mcode i1
->
3515 F.SeqEnd
(level
, i1
)
3518 | A.ExprStatement
(ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3519 let ib1 = tuple_of_list1 ii
in
3520 expression ea eb
>>= (fun ea eb
->
3521 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3523 A.ExprStatement
(ea
, ia1
),
3524 F.ExprStatement
(st
, (Some eb
, [ib1]))
3529 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
3530 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3531 expression ea eb
>>= (fun ea eb
->
3532 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3533 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3534 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3536 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
3537 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
3540 | A.Else ia
, F.Else ib
->
3541 tokenf ia ib
>>= (fun ia ib
->
3542 return (A.Else ia
, F.Else ib
)
3545 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
3546 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3547 expression ea eb
>>= (fun ea eb
->
3548 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3549 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3550 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3552 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
3553 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
3556 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
3557 tokenf ia ib
>>= (fun ia ib
->
3562 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
3563 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
3564 expression ea eb
>>= (fun ea eb
->
3565 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3566 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3567 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3568 tokenf ia4 ib4
>>= (fun ia4 ib4
->
3570 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
3571 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
3573 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
3575 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
3577 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
3578 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3579 tokenf ia3 ib3
>>= (fun ia3 ib3
->
3580 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
3581 let eas = redots
eas easundots
in
3583 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
3584 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
3589 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3590 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
3592 assert (null ib4vide
);
3593 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
3594 let ib3 = tuple_of_list1 ib3s
in
3595 let ib4 = tuple_of_list1 ib4s
in
3597 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3598 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3599 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3600 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
3601 tokenf ia5 ib5
>>= (fun ia5 ib5
->
3602 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
3603 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
3604 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
3606 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
3607 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
3613 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
3614 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
3615 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3616 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3617 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
3618 expression ea eb
>>= (fun ea eb
->
3620 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
3621 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
3624 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
3625 let (ib1, ib2
) = tuple_of_list2 ii
in
3626 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3627 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3630 F.Break
(st
, ((),[ib1;ib2
]))
3633 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
3634 let (ib1, ib2
) = tuple_of_list2 ii
in
3635 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3636 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3638 A.Continue
(ia1
, ia2
),
3639 F.Continue
(st
, ((),[ib1;ib2
]))
3642 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
3643 let (ib1, ib2
) = tuple_of_list2 ii
in
3644 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3645 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3647 A.Return
(ia1
, ia2
),
3648 F.Return
(st
, ((),[ib1;ib2
]))
3651 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
3652 let (ib1, ib2
) = tuple_of_list2 ii
in
3653 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3654 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3655 expression ea eb
>>= (fun ea eb
->
3657 A.ReturnExpr
(ia1
, ea
, ia2
),
3658 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
3663 | A.Include
(incla
,filea
),
3664 F.Include
{B.i_include
= (fileb
, ii
);
3665 B.i_rel_pos
= h_rel_pos
;
3666 B.i_is_in_ifdef
= inifdef
;
3669 assert (copt
=*= None
);
3671 let include_requirment =
3672 match mcodekind incla
, mcodekind filea
with
3673 | A.CONTEXT
(_
, A.BEFORE _
), _
->
3675 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
3681 let (inclb
, iifileb
) = tuple_of_list2 ii
in
3682 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
3684 tokenf incla inclb
>>= (fun incla inclb
->
3685 tokenf filea iifileb
>>= (fun filea iifileb
->
3687 A.Include
(incla
, filea
),
3688 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
3689 B.i_rel_pos
= h_rel_pos
;
3690 B.i_is_in_ifdef
= inifdef
;
3698 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
3699 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
3700 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
3701 tokenf definea defineb
>>= (fun definea defineb
->
3702 (match A.unwrap params
, defkind
with
3703 | A.NoParams
, B.DefineVar
->
3705 A.NoParams
+> A.rewrap params
,
3708 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
3709 let (lpb
, rpb
) = tuple_of_list2 ii
in
3710 tokenf lpa lpb
>>= (fun lpa lpb
->
3711 tokenf rpa rpb
>>= (fun rpa rpb
->
3713 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
3714 (fun easundots ebs
->
3715 let eas = redots
eas easundots
in
3717 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
3718 B.DefineFunc
(ebs
,[lpb
;rpb
])
3722 ) >>= (fun params defkind
->
3724 A.DefineHeader
(definea
, ida
, params
),
3725 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
3730 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
3731 let (ib1, ib2
) = tuple_of_list2 ii
in
3732 tokenf def
ib1 >>= (fun def
ib1 ->
3733 tokenf colon ib2
>>= (fun colon ib2
->
3735 A.Default
(def
,colon
),
3736 F.Default
(st
, ((),[ib1;ib2
]))
3741 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
3742 let (ib1, ib2
) = tuple_of_list2 ii
in
3743 tokenf case
ib1 >>= (fun case
ib1 ->
3744 expression ea eb
>>= (fun ea eb
->
3745 tokenf colon ib2
>>= (fun colon ib2
->
3747 A.Case
(case
,ea
,colon
),
3748 F.Case
(st
, (eb
,[ib1;ib2
]))
3751 (* only occurs in the predicates generated by asttomember *)
3752 | A.DisjRuleElem
eas, _
->
3754 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
3755 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
3757 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
3759 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
3760 let (ib2
) = tuple_of_list1 ii
in
3761 (match A.unwrap id
with
3763 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
3764 tokenf dd ib2
>>= (fun dd ib2
->
3767 F.Label
(st
,nameb
, ((),[ib2
]))
3769 | _
-> failwith
"labels with metavariables not supported"
3772 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
3773 let (ib1,ib3) = tuple_of_list2 ii
in
3774 tokenf goto
ib1 >>= (fun goto
ib1 ->
3775 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
3776 tokenf sem
ib3 >>= (fun sem
ib3 ->
3778 A.Goto
(goto
,id
,sem
),
3779 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
3782 (* have not a counter part in coccinelle, for the moment *)
3783 (* todo?: print a warning at least ? *)
3789 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
3793 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
3796 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
3797 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
3798 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
3799 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|F.MacroIterHeader
(_
, _
)|
3800 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
3801 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
3802 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
3803 F.Decl _
|F.FunHeader _
)