2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
32 module F
= Control_flow_c
34 module Flag
= Flag_matcher
36 (*****************************************************************************)
38 (*****************************************************************************)
39 let pr2, pr2_once
= Common.mk_pr2_wrappers
Flag_matcher.verbose_matcher
41 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
48 (Printf.sprintf
"%s: %d: %s"
49 (Ast_c.file_of_info ii
) (Ast_c.line_of_info ii
) str
)
51 (*****************************************************************************)
53 (*****************************************************************************)
55 type sequence
= Ordered
| Unordered
58 match A.unwrap eas
with
60 | A.CIRCLES _
-> Unordered
61 | A.STARS _
-> failwith
"not handling stars"
63 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
65 match A.unwrap eas
with
66 | A.DOTS _
-> A.DOTS easundots
67 | A.CIRCLES _
-> A.CIRCLES easundots
68 | A.STARS _
-> A.STARS easundots
72 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
74 ibs
+> List.exists
(fun (ib
, icomma
) ->
75 match B.unwrap ib
with
84 (* For the #include <linux/...> in the .cocci, need to find where is
85 * the '+' attached to this element, to later find the first concrete
86 * #include <linux/xxx.h> or last one in the series of #includes in the
89 type include_requirement
=
96 (* todo? put in semantic_c.ml *)
99 | LocalFunction
(* entails Function *)
103 let term mc
= A.unwrap_mcode mc
104 let mcodekind mc
= A.get_mcodekind mc
107 let mcode_contain_plus = function
108 | A.CONTEXT
(_
,A.NOTHING
) -> false
109 | A.CONTEXT _
-> true
110 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> false
111 | A.MINUS
(_
,_
,_
,A.REPLACEMENT _
) -> true (* repl is nonempty *)
112 | A.PLUS _
-> raise Impossible
114 let mcode_simple_minus = function
115 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> true
119 (* In transformation.ml sometime I build some mcodekind myself and
120 * julia has put None for the pos. But there is no possible raise
121 * NoMatch in those cases because it is for the minusall trick or for
122 * the distribute, so either have to build those pos, in fact a range,
123 * because for the distribute have to erase a fullType with one
124 * mcodekind, or add an argument to tag_with_mck such as "safe" that
125 * don't do the check_pos. Hence this DontCarePos constructor. *)
129 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[]},
130 (A.MINUS
(A.DontCarePos
,[],A.ALLMINUS
,A.NOREPLACEMENT
)),
133 let generalize_mcode ia
=
134 let (s1
, i
, mck
, pos
) = ia
in
137 | A.PLUS _
-> raise Impossible
138 | A.CONTEXT
(A.NoPos
,x
) ->
139 A.CONTEXT
(A.DontCarePos
,x
)
140 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
141 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
143 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
144 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
148 (s1
, i
, new_mck, pos
)
152 (*---------------------------------------------------------------------------*)
154 (* 0x0 is equivalent to 0, value format isomorphism *)
155 let equal_c_int s1 s2
=
157 int_of_string s1
=|= int_of_string s2
158 with Failure
("int_of_string") ->
163 (*---------------------------------------------------------------------------*)
164 (* Normally A should reuse some types of Ast_c, so those
165 * functions should not exist.
167 * update: but now Ast_c depends on A, so can't make too
168 * A depends on Ast_c, so have to stay with those equal_xxx
172 let equal_unaryOp a b
=
174 | A.GetRef
, B.GetRef
-> true
175 | A.GetRefLabel
, B.GetRefLabel
-> true
176 | A.DeRef
, B.DeRef
-> true
177 | A.UnPlus
, B.UnPlus
-> true
178 | A.UnMinus
, B.UnMinus
-> true
179 | A.Tilde
, B.Tilde
-> true
180 | A.Not
, B.Not
-> true
181 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
|B.GetRefLabel
) ->
186 let equal_arithOp a b
=
188 | A.Plus
, B.Plus
-> true
189 | A.Minus
, B.Minus
-> true
190 | A.Mul
, B.Mul
-> true
191 | A.Div
, B.Div
-> true
192 | A.Mod
, B.Mod
-> true
193 | A.DecLeft
, B.DecLeft
-> true
194 | A.DecRight
, B.DecRight
-> true
195 | A.And
, B.And
-> true
196 | A.Or
, B.Or
-> true
197 | A.Xor
, B.Xor
-> true
198 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
)
201 let equal_logicalOp a b
=
203 | A.Inf
, B.Inf
-> true
204 | A.Sup
, B.Sup
-> true
205 | A.InfEq
, B.InfEq
-> true
206 | A.SupEq
, B.SupEq
-> true
207 | A.Eq
, B.Eq
-> true
208 | A.NotEq
, B.NotEq
-> true
209 | A.AndLog
, B.AndLog
-> true
210 | A.OrLog
, B.OrLog
-> true
211 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
214 let equal_assignOp a b
=
216 | A.SimpleAssign
, B.SimpleAssign
-> true
217 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
218 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
220 let equal_fixOp a b
=
222 | A.Dec
, B.Dec
-> true
223 | A.Inc
, B.Inc
-> true
224 | _
, (B.Inc
|B.Dec
) -> false
226 let equal_binaryOp a b
=
228 | A.Arith a
, B.Arith b
-> equal_arithOp a b
229 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
230 | _
, (B.Logical _
| B.Arith _
) -> false
232 let equal_structUnion a b
=
234 | A.Struct
, B.Struct
-> true
235 | A.Union
, B.Union
-> true
236 | _
, (B.Struct
|B.Union
) -> false
240 | A.Signed
, B.Signed
-> true
241 | A.Unsigned
, B.UnSigned
-> true
242 | _
, (B.UnSigned
|B.Signed
) -> false
244 let equal_storage a b
=
246 | A.Static
, B.Sto
B.Static
247 | A.Auto
, B.Sto
B.Auto
248 | A.Register
, B.Sto
B.Register
249 | A.Extern
, B.Sto
B.Extern
251 | _
, (B.NoSto
| B.StoTypedef
) -> false
252 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
255 (*---------------------------------------------------------------------------*)
257 let equal_metavarval valu valu'
=
258 match valu
, valu'
with
259 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
260 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
261 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
262 (* do something more ? *)
265 (* al_expr before comparing !!! and accept when they match.
266 * Note that here we have Astc._expression, so it is a match
267 * modulo isomorphism (there is no metavariable involved here,
268 * just isomorphisms). => TODO call isomorphism_c_c instead of
269 * =*=. Maybe would be easier to transform ast_c in ast_cocci
270 * and call the iso engine of julia. *)
271 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
272 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
273 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
274 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
276 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
277 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
278 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
279 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
280 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
281 Lib_parsing_c.al_fields a
=*= Lib_parsing_c.al_fields b
282 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
283 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
284 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
285 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
286 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
287 Lib_parsing_c.al_inits a
=*= Lib_parsing_c.al_inits b
288 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
289 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
292 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
294 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
295 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
296 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
297 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
299 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
300 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
302 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
304 (function (fla
,cea
,posa1
,posa2
) ->
306 (function (flb
,ceb
,posb1
,posb2
) ->
307 fla
=$
= flb
&& cea
=$
= ceb
&&
308 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
312 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
313 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
314 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
315 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
316 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
320 (* probably only one argument needs to be stripped, because inherited
321 metavariables containing expressions are stripped in advance. But don't
322 know which one is which... *)
323 let equal_inh_metavarval valu valu'
=
324 match valu
, valu'
with
325 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
326 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
327 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
328 (* do something more ? *)
331 (* al_expr before comparing !!! and accept when they match.
332 * Note that here we have Astc._expression, so it is a match
333 * modulo isomorphism (there is no metavariable involved here,
334 * just isomorphisms). => TODO call isomorphism_c_c instead of
335 * =*=. Maybe would be easier to transform ast_c in ast_cocci
336 * and call the iso engine of julia. *)
337 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
338 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
339 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
340 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
342 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
343 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
344 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
345 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
346 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
347 Lib_parsing_c.al_inh_field_list a
=*= Lib_parsing_c.al_inh_field_list b
348 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
349 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
350 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
351 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
352 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
353 Lib_parsing_c.al_inh_inits a
=*= Lib_parsing_c.al_inh_inits b
354 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
355 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
358 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
360 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
361 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
362 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
363 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
365 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
366 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
368 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
370 (function (fla
,cea
,posa1
,posa2
) ->
372 (function (flb
,ceb
,posb1
,posb2
) ->
373 fla
=$
= flb
&& cea
=$
= ceb
&&
374 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
378 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
379 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
380 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
381 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
382 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
387 (*---------------------------------------------------------------------------*)
388 (* could put in ast_c.ml, next to the split/unsplit_comma *)
389 let split_signb_baseb_ii (baseb
, ii
) =
390 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
391 match baseb
, iis with
393 | B.Void
, ["void",i1
] -> None
, [i1
]
395 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
396 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
397 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
399 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
402 | B.IntType
(B.Si
(sign
, base
)), xs
->
406 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
407 | (B.Signed
,rest
) -> (None
,rest
)
408 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
409 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
410 (* The original code only allowed explicit signed and unsigned for char,
411 while this code allows char by itself. Not sure that needs to be
412 checked for here. If it does, then add a special case. *)
414 match (base
,rest
) with
415 B.CInt
, ["int",i1
] -> [i1
]
418 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
419 (match i1
.B.pinfo
with
421 | _
-> error [i1
] ("unrecognized signed int: "^
422 (String.concat
" "(List.map fst
iis))))
424 | B.CChar2
, ["char",i2
] -> [i2
]
426 | B.CShort
, ["short",i1
] -> [i1
]
427 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
429 | B.CLong
, ["long",i1
] -> [i1
]
430 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
432 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
433 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
436 error (List.map snd
iis)
437 ("strange type1, maybe because of weird order: "^
438 (String.concat
" " (List.map fst
iis))) in
441 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
442 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
443 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
446 error (List.map snd
iis)
447 ("strange type2, maybe because of weird order: "^
448 (String.concat
" " (List.map fst
iis)))
450 (*---------------------------------------------------------------------------*)
452 let rec unsplit_icomma xs
=
456 (match A.unwrap y
with
458 (x
, y
)::unsplit_icomma xs
459 | _
-> failwith
"wrong ast_cocci in initializer"
462 failwith
("wrong ast_cocci in initializer, should have pair " ^
467 let resplit_initialiser ibs iicomma
=
468 match iicomma
, ibs
with
471 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
473 error iicommas
"shouldn't have a iicomma"
474 | [iicomma
], x
::xs
->
475 let elems = List.map fst
(x
::xs
) in
476 let commas = List.map snd
(x
::xs
) +> List.flatten
in
477 let commas = commas @ [iicomma
] in
479 | _
-> raise Impossible
483 let rec split_icomma xs
=
486 | (x
,y
)::xs
-> x
::y
::split_icomma xs
488 let rec unsplit_initialiser ibs_unsplit
=
489 match ibs_unsplit
with
490 | [] -> [], [] (* empty iicomma *)
492 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
493 (x
, [])::xs
, lastcomma
495 and unsplit_initialiser_bis comma_before
= function
496 | [] -> [], [comma_before
]
498 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
499 (x
, [comma_before
])::xs
, lastcomma
504 (*---------------------------------------------------------------------------*)
505 (* coupling: same in type_annotater_c.ml *)
506 let structdef_to_struct_name ty
=
508 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
510 | Some s
, [i1
;i2
;i3
;i4
] ->
511 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
515 | x
-> raise Impossible
517 | _
-> raise Impossible
519 (*---------------------------------------------------------------------------*)
520 let one_initialisation_to_affectation x
=
521 let ({B.v_namei
= var
;
522 B.v_type
= returnType
;
523 B.v_type_bis
= tybis
;
524 B.v_storage
= storage
;
528 | Some
(name
, iniopt
) ->
530 | B.ValInit
(iini
, (B.InitExpr e
, ii_empty2
)) ->
533 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
535 (match Ast_c.info_of_type returnType
with
536 None
-> failwith
"no returnType info"
537 | Some ii
-> Ast_c.LocalVar ii
) in
539 (* old: Lib_parsing_c.al_type returnType
540 * but this type has not the typename completed so
541 * instead try to use tybis
544 | Some ty_with_typename_completed
-> ty_with_typename_completed
545 | None
-> raise Impossible
548 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
550 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
552 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
557 let initialisation_to_affectation decl
=
559 | B.MacroDecl _
-> F.Decl decl
560 | B.MacroDeclInit _
-> F.Decl decl
(* not sure... *)
561 | B.DeclList
(xs
, iis) ->
563 (* todo?: should not do that if the variable is an array cos
564 * will have x[] = , mais de toute facon ca sera pas un InitExp
566 let possible_assignment =
570 match prev
,one_initialisation_to_affectation x
with
572 | None
,Some x
-> Some x
573 | Some prev
,Some x
->
574 (* [] is clearly an invalid ii value for a sequence.
575 hope that no one looks at it, since nothing will
576 match the sequence. Fortunately, SmPL doesn't
577 support , expressions. *)
578 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
580 match possible_assignment with
581 Some x
-> F.DefineExpr x
582 | None
-> F.Decl decl
584 (*****************************************************************************)
585 (* Functor parameter combinators *)
586 (*****************************************************************************)
588 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
590 * version0: was not tagging the SP, so just tag the C
592 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
593 * val return : 'b -> tin -> 'b tout
594 * val fail : tin -> 'b tout
596 * version1: now also tag the SP so return a ('a * 'b)
599 type mode
= PatternMode
| TransformMode
607 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
612 (tin
-> ('a
* 'b
) tout
) ->
613 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
614 (tin
-> ('c
* 'd
) tout
)
616 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
617 val fail
: tin
-> ('a
* 'b
) tout
629 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
631 val tokenf
: ('a
A.mcode
, B.info
) matcher
632 val tokenf_mck
: (A.mcodekind, B.info
) matcher
635 (A.meta_name
A.mcode
, B.expression
) matcher
637 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
639 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
641 (A.meta_name
A.mcode
,
642 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
644 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
646 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
648 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
650 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
652 (A.meta_name
A.mcode
, Ast_c.field
) matcher
654 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
656 val distrf_define_params
:
657 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
659 val distrf_enum_fields
:
660 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
662 val distrf_struct_fields
:
663 (A.meta_name
A.mcode
, B.field list
) matcher
666 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
669 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
672 (A.expression
, B.expression
) matcher
->
673 (A.expression
, B.expression
) matcher
676 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
679 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
682 A.keep_binding
-> A.inherited
->
683 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
684 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
685 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
687 val check_idconstraint
:
688 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
689 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
691 val check_constraints_ne
:
692 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
693 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
695 val all_bound
: A.meta_name list
-> (tin
-> bool)
697 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
698 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
699 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
700 val optional_declarer_semicolon_flag
:
701 (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
705 (*****************************************************************************)
706 (* Functor code, "Cocci vs C" *)
707 (*****************************************************************************)
710 functor (X
: PARAM
) ->
713 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
716 let return = X.return
719 let (>||>) = X.(>||>)
720 let (>|+|>) = X.(>|+|>)
721 let (>&&>) = X.(>&&>)
723 let tokenf = X.tokenf
725 (* should be raise Impossible when called from transformation.ml *)
728 | PatternMode
-> fail
729 | TransformMode
-> raise Impossible
732 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
734 | (Some t1
, Some t2
) ->
735 f t1 t2
>>= (fun t1 t2
->
736 return (Some t1
, Some t2
)
738 | (None
, None
) -> return (None
, None
)
741 (* Dots are sometimes used as metavariables, since like metavariables they
742 can match other things. But they no longer have the same type. Perhaps these
743 functions could be avoided by introducing an appropriate level of polymorphism,
744 but I don't know how to declare polymorphism across functors *)
745 let dots2metavar (_
,info
,mcodekind,pos
) =
746 (("","..."),info
,mcodekind,pos
)
747 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
748 let metavar2ndots (_
,info
,mcodekind,pos
) = ("<+...",info
,mcodekind,pos
)
750 let satisfies_regexpconstraint c id
: bool =
752 A.IdRegExp
(_
,recompiled
) -> Regexp.string_match recompiled id
753 | A.IdNotRegExp
(_
,recompiled
) -> not
(Regexp.string_match recompiled id
)
755 let satisfies_iconstraint c id
: bool =
758 let satisfies_econstraint c exp
: bool =
759 let warning s
= pr2_once
("WARNING: "^s
); false in
760 match Ast_c.unwrap_expr exp
with
761 Ast_c.Ident
(name
) ->
763 Ast_c.RegularName rname
->
764 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
765 | Ast_c.CppConcatenatedName _
->
767 "Unable to apply a constraint on a CppConcatenatedName identifier!"
768 | Ast_c.CppVariadicName _
->
770 "Unable to apply a constraint on a CppVariadicName identifier!"
771 | Ast_c.CppIdentBuilder _
->
773 "Unable to apply a constraint on a CppIdentBuilder identifier!")
774 | Ast_c.Constant cst
->
776 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
777 | Ast_c.MultiString strlist
->
778 warning "Unable to apply a constraint on a multistring constant!"
779 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
780 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
781 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
782 | _
-> warning "Unable to apply a constraint on an expression!"
785 (* ------------------------------------------------------------------------- *)
786 (* This has to be up here to allow adequate polymorphism *)
788 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
789 match_metalist rebuild_metalist mktermval special_cases
790 element distrf get_iis
= fun eas ebs
->
791 let rec loop = function
792 [], [] -> return ([], [])
793 | [], eb
::ebs
-> fail
795 X.all_bound
(A.get_inherited ea
) >&&>
797 (match match_dots ea
, ebs
with
798 Some
(mcode
, optexpr
), ys
->
799 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
800 if optexpr
<> None
then failwith
"not handling when in a list";
802 (* '...' can take more or less the beginnings of the arguments *)
804 (* if eas is empty there is only one possible match.
805 the same if eas is just a comma *)
808 | [c
] when not
(ys
=[]) &&
809 (match match_comma c
with Some _
-> true | None
-> false) ->
810 let r = List.rev ys
in
811 [(List.rev
(List.tl
r),[List.hd
r])]
813 Common.zip
(Common.inits ys
) (Common.tails ys
) in
815 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
818 (* allow '...', and maybe its associated ',' to match nothing.
819 * for the associated ',' see below how we handle the EComma
824 if mcode_contain_plus (mcodekind mcode
)
827 "I have no token that I could accroche myself on"*)
828 else return (dots2metavar mcode
, [])
830 (* subtil: we dont want the '...' to match until the
831 * comma. cf -test pb_params_iso. We would get at
832 * "already tagged" error.
833 * this is because both f (... x, ...) and f (..., x, ...)
834 * would match a f(x,3) with our "optional-comma" strategy.
836 (match Common.last startxs
with
838 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
840 >>= (fun mcode startxs
->
841 let mcode = metavar2dots mcode in
842 loop (eas
, endxs
) >>= (fun eas endxs
->
844 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
852 (match match_comma ea
, ebs
with
853 | Some ia1
, Right ii
::ebs
->
855 (let ib1 = tuple_of_list1 ii
in
856 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
857 loop (eas
, ebs
) >>= (fun eas ebs
->
859 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
864 (* allow ',' to maching nothing. optional comma trick *)
866 (if mcode_contain_plus (mcodekind ia1
)
868 else loop (eas
, ebs
))
871 (match match_metalist ea
, ebs
with
872 Some
(ida
,leninfo
,keep
,inherited
), ys
->
874 Common.zip
(Common.inits ys
) (Common.tails ys
) in
876 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
881 if mcode_contain_plus (mcodekind ida
)
883 (* failwith "no token that I could accroche myself on" *)
886 (match Common.last startxs
with
893 let startxs'
= Ast_c.unsplit_comma
startxs in
894 let len = List.length
startxs'
in
897 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
898 let max_min _
= failwith
"no pos" in
899 X.envf lenkeep leninherited
900 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
903 then (function f
-> f
())
904 else (function f
-> fail)
905 | A.AnyListLen
-> function f
-> f
())
908 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
909 X.envf keep inherited
910 (ida
, mktermval
startxs'
, max_min)
913 then return (ida
, [])
914 else distrf ida
(Ast_c.split_comma
startxs'
))
915 >>= (fun ida
startxs ->
916 loop (eas
, endxs
) >>= (fun eas endxs
->
918 (rebuild_metalist
(ida
,leninfo
,keep
,inherited
))
927 special_cases ea eas ebs
in
928 match try_matches with
933 element ea eb
>>= (fun ea eb
->
934 loop (eas
, ebs
) >>= (fun eas ebs
->
935 return (ea
::eas
, Left eb
::ebs
)))
936 | (Right y
)::ys
-> raise Impossible
940 (*---------------------------------------------------------------------------*)
952 (*---------------------------------------------------------------------------*)
953 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
955 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
957 X.all_bound
(A.get_inherited ea
) >&&>
958 let wa x
= A.rewrap ea x
in
959 match A.unwrap ea
, eb
with
961 (* general case: a MetaExpr can match everything *)
962 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
963 (((expr
, opttypb
), ii
) as expb
) ->
965 (* old: before have a MetaConst. Now we factorize and use 'form' to
966 * differentiate between different cases *)
967 let rec matches_id = function
968 B.Ident
(name
) -> true
969 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
972 match (form
,expr
) with
975 let rec matches = function
976 B.Constant
(c
) -> true
977 | B.Ident
(nameidb
) ->
978 let s = Ast_c.str_of_name nameidb
in
979 if s =~
"^[A-Z_][A-Z_0-9]*$"
981 pr2_once
("warning: " ^
s ^
" treated as a constant");
985 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
986 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
987 | B.SizeOfExpr
(exp
) -> true
988 | B.SizeOfType
(ty
) -> true
994 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
996 | (A.ID
,e
) -> matches_id e
in
1000 (let (opttypb
,_testb
) = !opttypb
in
1001 match opttypa
, opttypb
with
1002 | None
, _
-> return ((),())
1004 pr2_once
("Missing type information. Certainly a pb in " ^
1005 "annotate_typer.ml");
1008 | Some tas
, Some tb
->
1009 tas
+> List.fold_left
(fun acc ta
->
1010 acc
>|+|> compatible_type ta tb
) fail
1013 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
1014 match constraints
with
1015 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
1016 | Ast_cocci.NotIdCstrt cstrt
->
1017 X.check_idconstraint
satisfies_econstraint cstrt eb
1018 (fun () -> return (meta_expr_val [],()))
1019 | Ast_cocci.NotExpCstrt cstrts
->
1020 X.check_constraints_ne expression cstrts eb
1021 (fun () -> return (meta_expr_val [],()))
1022 | Ast_cocci.SubExpCstrt cstrts
->
1023 return (meta_expr_val cstrts
,()))
1027 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1028 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1030 X.distrf_e ida expb
>>=
1033 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1041 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1042 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1044 * but bug! because if have not tagged SP, then transform without doing
1045 * any checks. Hopefully now have tagged SP technique.
1048 | A.AsExpr
(exp
,asexp
), expb
->
1049 expression exp expb
>>= (fun exp expb
->
1050 expression asexp expb
>>= (fun asexp expb
->
1052 ((A.AsExpr
(exp
,asexp
)) +> wa,
1056 * | A.Edots _, _ -> raise Impossible.
1058 * In fact now can also have the Edots inside normal expression, not
1059 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1061 | A.Edots
(mcode, None
), expb
->
1062 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1064 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1069 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1072 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1074 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1076 ((A.Ident ida
)) +> wa,
1077 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1083 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1085 (* todo?: handle some isomorphisms in int/float ? can have different
1086 * format : 1l can match a 1.
1088 * todo: normally string can contain some metavar too, so should
1089 * recurse on the string
1091 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1092 (* for everything except the String case where can have multi elems *)
1094 let ib1 = tuple_of_list1 ii
in
1095 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1097 ((A.Constant ia1
)) +> wa,
1098 ((B.Constant
(ib
), typ),[ib1])
1101 (match term ia1
, ib
with
1102 | A.Int x
, B.Int
(y
,_
) ->
1103 X.value_format_flag
(fun use_value_equivalence
->
1104 if use_value_equivalence
1114 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1116 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1119 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1122 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1124 ((A.Constant ia1
)) +> wa,
1125 ((B.Constant
(ib
), typ),[ib1])
1127 | _
-> fail (* multi string, not handled *)
1130 | _
, B.MultiString _
-> (* todo cocci? *) fail
1131 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1135 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1136 (* todo: do special case to allow IdMetaFunc, cos doing the
1137 * recursive call will be too late, match_ident will not have the
1138 * info whether it was a function. todo: but how detect when do
1139 * x.field = f; how know that f is a Func ? By having computed
1140 * some information before the matching!
1142 * Allow match with FunCall containing types. Now ast_cocci allow
1143 * type in parameter, and morover ast_cocci allow f(...) and those
1144 * ... could match type.
1146 let (ib1, ib2
) = tuple_of_list2 ii
in
1147 expression ea eb
>>= (fun ea eb
->
1148 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1149 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1150 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1151 let eas = redots
eas easundots
in
1153 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1154 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1157 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1158 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1159 let (opbi
) = tuple_of_list1 ii
in
1160 if equal_assignOp (term opa
) opb
1162 expression ea1 eb1
>>= (fun ea1 eb1
->
1163 expression ea2 eb2
>>= (fun ea2 eb2
->
1164 tokenf opa opbi
>>= (fun opa opbi
->
1166 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1167 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1171 | A.Sequence
(ea1
, opa
, ea2
),
1172 ((B.Sequence
(eb1
, eb2
), typ),ii
) ->
1173 let (opbi
) = tuple_of_list1 ii
in
1174 expression ea1 eb1
>>= (fun ea1 eb1
->
1175 expression ea2 eb2
>>= (fun ea2 eb2
->
1176 tokenf opa opbi
>>= (fun opa opbi
->
1178 (A.Sequence
(ea1
, opa
, ea2
)) +> wa,
1179 ((B.Sequence
(eb1
, eb2
), typ), [opbi
])
1182 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1183 let (ib1, ib2
) = tuple_of_list2 ii
in
1184 expression ea1 eb1
>>= (fun ea1 eb1
->
1185 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1186 expression ea3 eb3
>>= (fun ea3 eb3
->
1187 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1188 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1190 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1191 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1194 (* todo?: handle some isomorphisms here ? *)
1195 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1196 let opbi = tuple_of_list1 ii
in
1197 if equal_fixOp (term opa
) opb
1199 expression ea eb
>>= (fun ea eb
->
1200 tokenf opa
opbi >>= (fun opa
opbi ->
1202 ((A.Postfix
(ea
, opa
))) +> wa,
1203 ((B.Postfix
(eb
, opb
), typ),[opbi])
1208 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1209 let opbi = tuple_of_list1 ii
in
1210 if equal_fixOp (term opa
) opb
1212 expression ea eb
>>= (fun ea eb
->
1213 tokenf opa
opbi >>= (fun opa
opbi ->
1215 ((A.Infix
(ea
, opa
))) +> wa,
1216 ((B.Infix
(eb
, opb
), typ),[opbi])
1220 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1221 let opbi = tuple_of_list1 ii
in
1222 if equal_unaryOp (term opa
) opb
1224 expression ea eb
>>= (fun ea eb
->
1225 tokenf opa
opbi >>= (fun opa
opbi ->
1227 ((A.Unary
(ea
, opa
))) +> wa,
1228 ((B.Unary
(eb
, opb
), typ),[opbi])
1232 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1233 let opbi = tuple_of_list1 ii
in
1234 if equal_binaryOp (term opa
) opb
1236 expression ea1 eb1
>>= (fun ea1 eb1
->
1237 expression ea2 eb2
>>= (fun ea2 eb2
->
1238 tokenf opa
opbi >>= (fun opa
opbi ->
1240 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1241 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1245 | A.Nested
(ea1
, opa
, ea2
), eb
->
1247 expression ea1 eb
>|+|>
1249 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1250 when equal_binaryOp (term opa
) opb
->
1251 let opbi = tuple_of_list1 ii
in
1253 (expression ea1 eb1
>>= (fun ea1 eb1
->
1254 expression ea2 eb2
>>= (fun ea2 eb2
->
1255 tokenf opa
opbi >>= (fun opa
opbi ->
1257 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1258 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1261 (expression ea2 eb1
>>= (fun ea2 eb1
->
1262 expression ea1 eb2
>>= (fun ea1 eb2
->
1263 tokenf opa
opbi >>= (fun opa
opbi ->
1265 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1266 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1269 (expression ea2 eb2
>>= (fun ea2 eb2
->
1270 tokenf opa
opbi >>= (fun opa
opbi ->
1271 (* be last, to be sure the rest is marked *)
1272 loop eb1
>>= (fun ea1 eb1
->
1274 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1275 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1278 (expression ea2 eb1
>>= (fun ea2 eb1
->
1279 tokenf opa
opbi >>= (fun opa
opbi ->
1280 (* be last, to be sure the rest is marked *)
1281 loop eb2
>>= (fun ea1 eb2
->
1283 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1284 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1286 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1290 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1291 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1292 let (ib1, ib2
) = tuple_of_list2 ii
in
1293 expression ea1 eb1
>>= (fun ea1 eb1
->
1294 expression ea2 eb2
>>= (fun ea2 eb2
->
1295 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1296 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1298 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1299 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1302 (* todo?: handle some isomorphisms here ? *)
1303 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(eb
, idb
), typ),ii
) ->
1304 let (ib1) = tuple_of_list1 ii
in
1305 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1306 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1307 expression ea eb
>>= (fun ea eb
->
1309 ((A.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1310 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1315 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1316 let (ib1) = tuple_of_list1 ii
in
1317 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1318 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1319 expression ea eb
>>= (fun ea eb
->
1321 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1322 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1326 (* todo?: handle some isomorphisms here ?
1327 * todo?: do some iso-by-absence on cast ?
1328 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1331 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1332 let (ib1, ib2
) = tuple_of_list2 ii
in
1333 fullType typa typb
>>= (fun typa typb
->
1334 expression ea eb
>>= (fun ea eb
->
1335 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1336 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1338 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1339 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1342 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1343 let ib1 = tuple_of_list1 ii
in
1344 expression ea eb
>>= (fun ea eb
->
1345 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1347 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1348 ((B.SizeOfExpr
(eb
), typ),[ib1])
1351 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1352 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1353 fullType typa typb
>>= (fun typa typb
->
1354 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1355 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1356 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1358 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1359 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1363 (* todo? iso ? allow all the combinations ? *)
1364 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1365 let (ib1, ib2
) = tuple_of_list2 ii
in
1366 expression ea eb
>>= (fun ea eb
->
1367 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1368 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1370 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1371 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1374 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1375 (match A.unwrap exps
with
1377 X.cocciExpExp expression exp eb
>>= (fun exp eb
->
1378 X.distrf_e
(dots2metavar starter
) eb
>>= (fun mcode eb
->
1381 (metavar2ndots mcode,
1382 A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1388 "for nestexpr, only handling the case with dots and only one exp")
1390 | A.NestExpr _
, _
->
1391 failwith
"only handling multi and no when code in a nest expr"
1393 (* only in arg lists or in define body *)
1394 | A.TypeExp _
, _
-> fail
1396 | A.Constructor
(ia1
, typa
, ia2
, ia
), ((B.Constructor
(typb
, ib
), typ),ii
) ->
1397 let (ib1, ib2
) = tuple_of_list2 ii
in
1398 fullType typa typb
>>= (fun typa typb
->
1399 initialiser ia ib
>>= (fun ia ib
->
1400 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1401 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1403 ((A.Constructor
(ia1
, typa
, ia2
, ia
))) +> wa,
1404 ((B.Constructor
(typb
, ib
),typ),[ib1;ib2
])
1407 (* only in arg lists *)
1408 | A.MetaExprList _
, _
1415 | A.DisjExpr
eas, eb
->
1416 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1418 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1419 failwith
"not handling Opt/Unique/Multi on expr"
1421 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1423 (* have not a counter part in coccinelle, for the moment *)
1424 | _
, ((B.Sequence _
,_
),_
)
1425 | _
, ((B.StatementExpr _
,_
),_
)
1426 | _
, ((B.New _
,_
),_
)
1427 | _
, ((B.Delete _
,_
),_
)
1432 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1433 B.Constructor
(_
, _
)|
1434 B.RecordPtAccess
(_
, _
)|
1435 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1436 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1437 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1438 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1439 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1447 (* ------------------------------------------------------------------------- *)
1448 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1449 fun infoidb ida idb
->
1451 | B.RegularName
(s, iis) ->
1452 let iis = tuple_of_list1
iis in
1453 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1456 (B.RegularName
(s, [iis]))
1458 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1460 (* This should be moved to the Id case of ident. Metavariables
1461 should be allowed to be bound to such variables. But doing so
1462 would require implementing an appropriate distr function *)
1465 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1466 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1467 let check_constraints constraints idb
=
1468 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1469 match constraints
with
1470 A.IdNoConstraint
-> return (meta_id_val [],())
1471 | A.IdNegIdSet
(str
,meta
) ->
1472 X.check_idconstraint
satisfies_iconstraint str idb
1473 (fun () -> return (meta_id_val meta
,()))
1474 | A.IdRegExpConstraint re
->
1475 X.check_idconstraint
satisfies_regexpconstraint re idb
1476 (fun () -> return (meta_id_val [],())) in
1477 X.all_bound
(A.get_inherited ida
) >&&>
1478 match A.unwrap ida
with
1480 if (term sa
) =$
= idb
then
1481 tokenf sa iib
>>= (fun sa iib
->
1483 ((A.Id sa
)) +> A.rewrap ida
,
1488 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1489 check_constraints constraints idb
>>=
1491 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1492 (* use drop_pos for ids so that the pos is not added a second time in
1493 the call to tokenf *)
1494 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1496 tokenf mida iib
>>= (fun mida iib
->
1498 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1503 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1505 check_constraints constraints idb
>>=
1507 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1508 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1510 tokenf mida iib
>>= (fun mida iib
->
1512 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1517 | LocalFunction
| Function
-> is_function()
1519 failwith
"MetaFunc, need more semantic info about id"
1520 (* the following implementation could possibly be useful, if one
1521 follows the convention that a macro is always in capital letters
1522 and that a macro is not a function.
1523 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1526 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1529 check_constraints constraints idb
>>=
1531 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1532 X.envf keep inherited
1533 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1535 tokenf mida iib
>>= (fun mida iib
->
1537 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1543 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1546 (* not clear why disj things are needed, after disjdistr? *)
1548 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1550 | A.OptIdent _
| A.UniqueIdent _
->
1551 failwith
"not handling Opt/Unique for ident"
1553 (* ------------------------------------------------------------------------- *)
1554 and (arguments
: sequence
->
1555 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1556 fun seqstyle eas ebs
->
1558 | Unordered
-> failwith
"not handling ooo"
1560 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1561 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1563 (* because '...' can match nothing, need to take care when have
1564 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1565 * f(1,2) for instance.
1566 * So I have added special cases such as (if startxs = []) and code
1567 * in the Ecomma matching rule.
1569 * old: Must do some try, for instance when f(...,X,Y,...) have to
1570 * test the transfo for all the combinations and if multiple transfo
1571 * possible ? pb ? => the type is to return a expression option ? use
1572 * some combinators to help ?
1573 * update: with the tag-SP approach, no more a problem.
1576 and arguments_bis
= fun eas ebs
->
1578 match A.unwrap ea
with
1579 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1581 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1582 let match_comma ea
=
1583 match A.unwrap ea
with
1584 A.EComma ia1
-> Some ia1
1586 let build_comma ia1
= A.EComma ia1
in
1587 let match_metalist ea
=
1588 match A.unwrap ea
with
1589 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1590 Some
(ida
,leninfo
,keep
,inherited
)
1592 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1593 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1594 let mktermval v
= Ast_c.MetaExprListVal v
in
1595 let special_cases ea
eas ebs
= None
in
1596 list_matcher match_dots build_dots match_comma build_comma
1597 match_metalist build_metalist mktermval
1598 special_cases argument
X.distrf_args
1599 Lib_parsing_c.ii_of_args
eas ebs
1601 and argument arga argb
=
1602 X.all_bound
(A.get_inherited arga
) >&&>
1603 match A.unwrap arga
, argb
with
1605 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1606 if b
|| sopt
<> None
1608 (* failwith "the argument have a storage and ast_cocci does not have"*)
1611 (* b = false and sopt = None *)
1612 fullType tya tyb
>>= (fun tya tyb
->
1614 (A.TypeExp tya
) +> A.rewrap arga
,
1615 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1620 | A.TypeExp tya
, _
-> fail
1621 | _
, Right
(B.ArgType _
) -> fail
1623 expression arga argb
>>= (fun arga argb
->
1624 return (arga
, Left argb
)
1626 | _
, Right
(B.ArgAction y
) -> fail
1629 (* ------------------------------------------------------------------------- *)
1630 (* todo? facto code with argument ? *)
1631 and (parameters
: sequence
->
1632 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1634 fun seqstyle eas ebs
->
1636 | Unordered
-> failwith
"not handling ooo"
1638 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1639 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1643 and parameters_bis
eas ebs
=
1645 match A.unwrap ea
with
1646 A.Pdots
(mcode) -> Some
(mcode, None
)
1648 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1649 let match_comma ea
=
1650 match A.unwrap ea
with
1651 A.PComma ia1
-> Some ia1
1653 let build_comma ia1
= A.PComma ia1
in
1654 let match_metalist ea
=
1655 match A.unwrap ea
with
1656 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1657 Some
(ida
,leninfo
,keep
,inherited
)
1659 let build_metalist (ida
,leninfo
,keep
,inherited
) =
1660 A.MetaParamList
(ida
,leninfo
,keep
,inherited
) in
1661 let mktermval v
= Ast_c.MetaParamListVal v
in
1662 let special_cases ea
eas ebs
=
1663 (* a case where one smpl parameter matches a list of C parameters *)
1664 match A.unwrap ea
,ebs
with
1665 A.VoidParam ta
, ys
->
1667 (match eas, ebs
with
1669 let {B.p_register
=(hasreg
,iihasreg
);
1671 p_type
=tb
; } = eb
in
1673 if idbopt
=*= None
&& not hasreg
1676 | (qub
, (B.BaseType
B.Void
,_
)) ->
1677 fullType ta tb
>>= (fun ta tb
->
1679 [(A.VoidParam ta
) +> A.rewrap ea
],
1680 [Left
{B.p_register
=(hasreg
, iihasreg
);
1688 list_matcher match_dots build_dots match_comma build_comma
1689 match_metalist build_metalist mktermval
1690 special_cases parameter
X.distrf_params
1691 Lib_parsing_c.ii_of_params
eas ebs
1694 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1695 match hasreg, idb, ii_b_s with
1696 | false, Some s, [i1] -> Left (s, [], i1)
1697 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1698 | _, None, ii -> Right ii
1699 | _ -> raise Impossible
1703 and parameter
= fun parama paramb
->
1704 match A.unwrap parama
, paramb
with
1705 A.MetaParam
(ida
,keep
,inherited
), eb
->
1706 (* todo: use quaopt, hasreg ? *)
1708 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1709 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1710 X.distrf_param ida eb
1711 ) >>= (fun ida eb
->
1712 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1713 | A.Param
(typa
, idaopt
), eb
->
1714 let {B.p_register
= (hasreg
,iihasreg
);
1715 p_namei
= nameidbopt
;
1716 p_type
= typb
;} = paramb
in
1718 fullType typa typb
>>= (fun typa typb
->
1719 match idaopt
, nameidbopt
with
1720 | Some ida
, Some nameidb
->
1721 (* todo: if minus on ida, should also minus the iihasreg ? *)
1722 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1724 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1725 {B.p_register
= (hasreg
, iihasreg
);
1726 p_namei
= Some
(nameidb
);
1732 A.Param
(typa
, None
)+> A.rewrap parama
,
1733 {B.p_register
=(hasreg
,iihasreg
);
1737 (* why handle this case ? because of transform_proto ? we may not
1738 * have an ident in the proto.
1739 * If have some plus on ida ? do nothing about ida ?
1741 (* not anymore !!! now that julia is handling the proto.
1742 | _, Right iihasreg ->
1745 ((hasreg, None, typb), iihasreg)
1749 | Some _
, None
-> fail
1750 | None
, Some _
-> fail)
1751 | (A.OptParam _
| A.UniqueParam _
), _
->
1752 failwith
"not handling Opt/Unique for Param"
1753 | A.Pcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
1756 (* ------------------------------------------------------------------------- *)
1757 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1758 fun (mckstart
, allminus
, decla
) declb
->
1759 X.all_bound
(A.get_inherited decla
) >&&>
1760 match A.unwrap decla
, declb
with
1762 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1763 * de toutes les declarations qui sont au debut d'un fonction et
1764 * commencer le reste du match au premier statement. Alors, ca matche
1765 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1766 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1768 * When the SP want to remove the whole function, the minus is not
1769 * on the MetaDecl but on the MetaRuleElem. So there should
1770 * be no transform of MetaDecl, just matching are allowed.
1773 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1775 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1776 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1777 X.distrf_decl ida declb
1778 ) >>= (fun ida declb
->
1779 return ((mckstart
, allminus
,
1780 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1783 | A.AsDecl
(dec
,asdec
), decb
->
1784 declaration
(mckstart
, allminus
, dec
) decb
>>=
1785 (fun (mckstart
, allminus
, dec
) decb
->
1786 let asmckstart = A.CONTEXT
(A.NoPos
,A.NOTHING
) in
1787 declaration
(asmckstart,false,asdec
) decb
>>= (fun (_
,_
,asdec
) decb
->
1789 ((mckstart
, allminus
,
1790 (A.AsDecl
(dec
,asdec
)) +> A.rewrap decla
),
1793 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1794 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1795 (fun decla
(var
,iiptvirgb
,iisto
)->
1796 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1798 (mckstart
, allminus
, decla
),
1799 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1802 | _
, (B.DeclList
(xs
, ((iiptvirgb
::iifakestart
::iisto
) as ii
))) ->
1804 let rec loop n
= function
1806 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1808 let rec repln n vl cur
= function
1811 if n
= cur
then vl
:: xs
else x
:: (repln n vl
(cur
+1) xs
) in
1812 if X.mode
=*= PatternMode
|| A.get_safe_decl decla
1814 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1815 (* consider all possible matches *)
1816 acc
>||> (function tin
-> (
1817 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1818 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1819 (fun decla
(var
, iiptvirgb
, iisto
) ->
1821 (mckstart
, allminus
, decla
),
1822 (* adjust the variable that was chosen *)
1823 (B.DeclList
(repln n var
0 xs
,
1824 iiptvirgb
::iifakestart
::iisto
))
1829 "More than one variable in the declaration, and so it cannot be transformed. Check that there is no transformation on the type or the ;"
1831 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
,true),ii
) ->
1832 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1834 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1835 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1836 | _
-> raise Impossible
1839 then minusize_list iistob
1840 else return ((), iistob
)
1841 ) >>= (fun () iistob
->
1843 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1844 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1845 tokenf lpa lpb
>>= (fun lpa lpb
->
1846 tokenf rpa rpb
>>= (fun rpa rpb
->
1847 tokenf enda iiendb
>>= (fun enda iiendb
->
1848 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1849 let eas = redots
eas easundots
in
1852 (mckstart
, allminus
,
1853 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1854 (B.MacroDecl
((sb
,ebs
,true),
1855 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1858 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
,false),ii
) ->
1859 X.optional_declarer_semicolon_flag
(fun optional_declarer_semicolon
->
1860 match mcodekind enda
, optional_declarer_semicolon
with
1861 A.CONTEXT
(_
,A.NOTHING
), true ->
1862 let (iisb
, lpb
, rpb
, iifakestart
, iistob
) =
1864 | iisb
::lpb
::rpb
::iifakestart
::iisto
->
1865 (iisb
,lpb
,rpb
,iifakestart
,iisto
)
1866 | _
-> raise Impossible
) in
1868 then minusize_list iistob
1869 else return ((), iistob
)) >>=
1872 X.tokenf_mck mckstart iifakestart
>>=
1873 (fun mckstart iifakestart
->
1874 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1875 tokenf lpa lpb
>>= (fun lpa lpb
->
1876 tokenf rpa rpb
>>= (fun rpa rpb
->
1877 arguments
(seqstyle eas) (A.undots
eas) ebs
>>=
1878 (fun easundots ebs
->
1879 let eas = redots
eas easundots
in
1882 (mckstart
, allminus
,
1883 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1884 (B.MacroDecl
((sb
,ebs
,false),
1885 [iisb
;lpb
;rpb
;iifakestart
] ++ iistob
))
1889 | A.MacroDeclInit
(sa
,lpa
,eas,rpa
,weqa
,inia
,enda
),
1890 B.MacroDeclInit
((sb
,ebs
,inib
),ii
) ->
1891 let (iisb
, lpb
, rpb
, weqb
, iiendb
, iifakestart
, iistob
) =
1893 | iisb
::lpb
::rpb
::weqb
::iiendb
::iifakestart
::iisto
->
1894 (iisb
,lpb
,rpb
,weqb
,iiendb
, iifakestart
,iisto
)
1895 | _
-> raise Impossible
1898 then minusize_list iistob
1899 else return ((), iistob
)
1900 ) >>= (fun () iistob
->
1902 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1903 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1904 tokenf lpa lpb
>>= (fun lpa lpb
->
1905 tokenf rpa rpb
>>= (fun rpa rpb
->
1906 tokenf rpa rpb
>>= (fun rpa rpb
->
1907 tokenf weqa weqb
>>= (fun weqa weqb
->
1908 tokenf enda iiendb
>>= (fun enda iiendb
->
1909 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1910 initialiser inia inib
>>= (fun inia inib
->
1911 let eas = redots
eas easundots
in
1914 (mckstart
, allminus
,
1915 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1916 (B.MacroDecl
((sb
,ebs
,true),
1917 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1919 | _
, (B.MacroDecl _
|B.MacroDeclInit _
|B.DeclList _
) -> fail
1922 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1923 X.all_bound
(A.get_inherited decla
) >&&>
1924 match A.unwrap decla
, declb
with
1926 (* kind of typedef iso, we must unfold, it's for the case
1927 * T { }; that we want to match against typedef struct { } xx_t;
1930 | A.TyDecl
(tya0
, ptvirga
),
1931 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
1933 B.v_storage
= (B.StoTypedef
, inl
);
1936 B.v_type_bis
= typb0bis
;
1939 (match A.unwrap tya0
, typb0
with
1940 | A.Type
(allminus
,cv1
,tya1
), ((qu
,il
),typb1
) ->
1941 (* allminus doesn't seem useful here - nothing done with cv1 *)
1943 (match A.unwrap tya1
, typb1
with
1944 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
1945 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
1947 let (iisub
, iisbopt
, lbb
, rbb
) =
1950 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
1951 (iisub
, [], lbb
, rbb
)
1954 "warning: both a typedef (%s) and struct name introduction (%s)"
1955 (Ast_c.str_of_name nameidb
) s
1957 pr2 "warning: I will consider only the typedef";
1958 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
1959 (iisub
, [iisb
], lbb
, rbb
)
1962 structdef_to_struct_name
1963 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
1966 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
1967 (Lib_parsing_c.al_type
structnameb))), [])
1970 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
1971 tokenf lba lbb
>>= (fun lba lbb
->
1972 tokenf rba rbb
>>= (fun rba rbb
->
1973 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
1974 let declsa = redots
declsa undeclsa
in
1976 (match A.unwrap tya2
with
1977 | A.Type
(allminus
, cv3
, tya3
) -> (* again allminus not used *)
1978 (match A.unwrap tya3
with
1979 | A.MetaType
(ida
,keep
, inherited
) ->
1981 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
1983 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
1984 let tya0 = A.Type
(allminus
, cv1
, tya1) +> A.rewrap
tya0 in
1987 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
1988 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
1989 let typb0 = ((qu
, il
), typb1) in
1991 match fake_typeb with
1992 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
1995 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
1996 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
1998 B.v_storage
= (B.StoTypedef
, inl
);
2001 B.v_type_bis
= typb0bis
;
2003 iivirg
),iiptvirgb
,iistob
)
2005 | _
-> raise Impossible
2008 (* do we need EnumName here too? *)
2009 | A.StructUnionName
(sua
, sa
) ->
2010 fullType tya2
structnameb >>= (fun tya2
structnameb ->
2012 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
2014 let tya0 = A.Type
(allminus
, cv1
, tya1) +> A.rewrap
tya0 in
2016 match structnameb with
2017 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
2019 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
2020 [iisub
;iisbopt
;lbb
;rbb
] in
2021 let typb0 = ((qu
, il
), typb1) in
2024 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
2025 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2027 B.v_storage
= (B.StoTypedef
, inl
);
2030 B.v_type_bis
= typb0bis
;
2032 iivirg
),iiptvirgb
,iistob
)
2034 | _
-> raise Impossible
2036 | _
-> raise Impossible
2045 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
2046 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
2049 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2050 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
2055 (* could handle iso here but handled in standard.iso *)
2056 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
2057 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2062 B.v_type_bis
= typbbis
;
2064 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2065 fullType typa typb
>>= (fun typa typb
->
2066 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2067 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2068 (fun stoa
(stob
, iistob
) ->
2070 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2071 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2076 B.v_type_bis
= typbbis
;
2081 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2082 ({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
2087 B.v_type_bis
= typbbis
;
2090 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2091 tokenf eqa iieqb
>>= (fun eqa iieqb
->
2092 fullType typa typb
>>= (fun typa typb
->
2093 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2094 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2095 (fun stoa
(stob
, iistob
) ->
2096 initialiser inia inib
>>= (fun inia inib
->
2098 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
2099 (({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
2104 B.v_type_bis
= typbbis
;
2109 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2110 ({B.v_namei
= Some
(nameidb
, B.ConstrInit _
);
2115 B.v_type_bis
= typbbis
;
2117 -> fail (* C++ constructor declaration not supported in SmPL *)
2119 (* do iso-by-absence here ? allow typedecl and var ? *)
2120 | A.TyDecl
(typa
, ptvirga
),
2121 ({B.v_namei
= None
; B.v_type
= typb
;
2125 B.v_type_bis
= typbbis
;
2128 if stob
=*= (B.NoSto
, false)
2130 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2131 fullType typa typb
>>= (fun typa typb
->
2133 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2134 (({B.v_namei
= None
;
2139 B.v_type_bis
= typbbis
;
2140 }, iivirg
), iiptvirgb
, iistob
)
2145 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2146 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2148 B.v_storage
= (B.StoTypedef
,inline
);
2151 B.v_type_bis
= typbbis
;
2154 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2155 fullType typa typb
>>= (fun typa typb
->
2158 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2159 return (stoa
, [iitypedef
])
2161 | _
-> error iistob
"weird, have both typedef and inline or nothing";
2162 ) >>= (fun stoa iistob
->
2163 (match A.unwrap ida
with
2164 | A.MetaType
(_
,_
,_
) ->
2167 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2169 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2170 match fake_typeb with
2171 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2172 return (ida
, nameidb
)
2173 | _
-> raise Impossible
2178 | B.RegularName
(sb
, iidb
) ->
2179 let iidb1 = tuple_of_list1 iidb
in
2183 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2185 (A.TypeName sa
) +> A.rewrap ida
,
2186 B.RegularName
(sb
, [iidb1])
2190 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2194 | _
-> raise Impossible
2196 ) >>= (fun ida nameidb
->
2198 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2199 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2201 B.v_storage
= (B.StoTypedef
,inline
);
2204 B.v_type_bis
= typbbis
;
2212 | _
, ({B.v_namei
= None
;}, _
) ->
2213 (* old: failwith "no variable in this declaration, weird" *)
2218 | A.DisjDecl declas
, declb
->
2219 declas
+> List.fold_left
(fun acc decla
->
2221 (* (declaration (mckstart, allminus, decla) declb) *)
2222 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2227 (* only in struct type decls *)
2228 | A.Ddots
(dots
,whencode
), _
->
2231 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2232 failwith
"not handling Opt/Unique Decl"
2234 | _
, ({B.v_namei
=Some _
}, _
) ->
2240 (* ------------------------------------------------------------------------- *)
2242 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2243 X.all_bound
(A.get_inherited ia
) >&&>
2244 match (A.unwrap ia
,ib
) with
2246 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2248 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2249 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2251 X.distrf_ini ida ib
>>= (fun ida ib
->
2253 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2258 | A.AsInit
(ini
,asini
), inib
->
2259 initialiser ini inib
>>= (fun ini inib
->
2260 initialiser asini inib
>>= (fun asini inib
->
2262 ((A.AsInit
(ini
,asini
)) +> A.rewrap ia
,
2265 | (A.InitExpr expa
, ib
) ->
2266 (match A.unwrap expa
, ib
with
2267 | A.Edots
(mcode, None
), ib
->
2268 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2271 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2276 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2278 | _
, (B.InitExpr expb
, ii
) ->
2280 expression expa expb
>>= (fun expa expb
->
2282 (A.InitExpr expa
) +> A.rewrap ia
,
2283 (B.InitExpr expb
, ii
)
2288 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2290 | ib1::ib2
::iicommaopt
->
2291 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2292 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2293 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2294 (fun iasundots
(ibs
,iicommaopt
) ->
2296 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2297 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2300 | _
-> raise Impossible
2303 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2305 | ib1::ib2
::iicommaopt
->
2306 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2307 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2308 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2309 (fun ias
(ibs
,iicommaopt
) ->
2311 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2312 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2315 | _
-> raise Impossible
2318 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2319 (B.InitList ibs
, _ii
)) ->
2320 failwith
"TODO: not handling whencode in initialisers"
2323 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2324 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2326 let iieq = tuple_of_list1 ii2
in
2328 tokenf ia2
iieq >>= (fun ia2
iieq ->
2329 designators designatorsa designatorsb
>>=
2330 (fun designatorsa designatorsb
->
2331 initialiser inia inib
>>= (fun inia inib
->
2333 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2334 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2340 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2343 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2344 initialiser inia inib
>>= (fun inia inib
->
2345 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2347 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2348 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2355 | A.IComma
(comma
), _
->
2358 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2359 failwith
"not handling Opt/Unique on initialisers"
2361 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2362 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2364 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2367 and designators dla dlb
=
2368 match (dla
,dlb
) with
2369 ([],[]) -> return ([], [])
2370 | ([],_
) | (_
,[]) -> fail
2371 | (da
::dla
,db
::dlb
) ->
2372 designator da db
>>= (fun da db
->
2373 designators dla dlb
>>= (fun dla dlb
->
2374 return (da
::dla
, db
::dlb
)))
2376 and designator da db
=
2378 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2380 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2381 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2382 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2384 A.DesignatorField
(ia1
, ida
),
2385 (B.DesignatorField idb
, [iidot
;iidb
])
2388 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2390 let (ib1, ib2
) = tuple_of_list2 ii1
in
2391 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2392 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2393 expression ea eb
>>= (fun ea eb
->
2395 A.DesignatorIndex
(ia1
,ea
,ia2
),
2396 (B.DesignatorIndex eb
, [ib1;ib2
])
2399 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2400 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2402 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2403 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2404 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2405 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2406 expression e1a e1b
>>= (fun e1a e1b
->
2407 expression e2a e2b
>>= (fun e2a e2b
->
2409 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2410 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2412 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2415 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2416 let ias_unsplit = unsplit_icomma ias
in
2417 let ibs_split = resplit_initialiser ibs iicomma
in
2419 if need_unordered_initialisers ibs
2421 initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2422 (fun ias_unsplit ibs_split ->
2424 split_icomma ias_unsplit,
2425 unsplit_initialiser ibs_split))
2428 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2429 (* this doesn't check need_unordered_initialisers because ... can be
2430 implemented as ordered, even if it matches unordered initializers *)
2431 let ibs = resplit_initialiser ibs iicomma
in
2434 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2435 initialisers_ordered2 ias
ibs >>=
2436 (fun ias
ibs_split ->
2439 match List.rev
ibs_split with
2440 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2441 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2443 return (ias
, (ibs,iicomma
)))
2445 and initialisers_ordered2
= fun ias
ibs ->
2447 match A.unwrap ea
with
2448 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2450 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2451 let match_comma ea
=
2452 match A.unwrap ea
with
2453 A.IComma ia1
-> Some ia1
2455 let build_comma ia1
= A.IComma ia1
in
2456 let match_metalist ea
=
2457 match A.unwrap ea
with
2458 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) ->
2459 Some
(ida
,leninfo
,keep
,inherited
)
2461 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2462 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) in
2463 let mktermval v
= Ast_c.MetaInitListVal v
in
2464 let special_cases ea
eas ebs
= None
in
2465 let no_ii x
= failwith
"not possible" in
2466 list_matcher match_dots build_dots match_comma build_comma
2467 match_metalist build_metalist mktermval
2468 special_cases initialiser
X.distrf_inis
no_ii ias
ibs
2470 and initialisers_unordered2
= fun allminus ias
ibs ->
2475 let rec loop = function
2476 [] -> return ([],[])
2477 | (ib
,comma
)::ibs ->
2478 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2479 tokenf minusizer comma
>>= (fun _ comma
->
2480 loop ibs >>= (fun l
ibs ->
2481 return(l
,(ib
,comma
)::ibs)))) in
2483 else return ([], ys
)
2485 let permut = Common.uncons_permut_lazy ys
in
2486 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2488 (initialiser_comma x e
2490 let rest = Lazy.force
rest in
2491 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2494 Common.insert_elem_pos
(e
, pos
) rest
2498 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2499 match A.unwrap xcomma
with
2501 tokenf commax commay
>>= (fun commax commay
->
2502 initialiser x y
>>= (fun x y
->
2504 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2506 | _
-> raise Impossible
(* unsplit_iicomma wrong *)
2508 (* ------------------------------------------------------------------------- *)
2509 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2512 match A.unwrap ea
with
2513 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2515 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2516 let match_comma ea
= None
in
2517 let build_comma ia1
= failwith
"not possible" in
2518 let match_metalist ea
=
2519 match A.unwrap ea
with
2520 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) ->
2521 Some
(ida
,leninfo
,keep
,inherited
)
2523 let build_metalist (ida
,leninfo
,keep
,inherited
) =
2524 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) in
2526 (* drop empty ii information, because nothing between elements *)
2527 let v = List.map
Ast_c.unwrap
v in
2528 Ast_c.MetaFieldListVal
v in
2529 let special_cases ea
eas ebs
= None
in
2530 let no_ii x
= failwith
"not possible" in
2531 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2532 let unmake_ebs ebs
=
2533 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2534 let distrf mcode startxs =
2535 let startxs = unmake_ebs startxs in
2536 X.distrf_struct_fields
mcode startxs >>=
2537 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2538 list_matcher match_dots build_dots match_comma build_comma
2539 match_metalist build_metalist mktermval
2540 special_cases struct_field
distrf no_ii eas (make_ebs ebs
) >>=
2541 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2543 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2545 match A.unwrap fa
,fb
with
2546 | A.MetaField
(ida
,keep
,inherited
), _
->
2548 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2549 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2550 X.distrf_field ida fb
2551 ) >>= (fun ida fb
->
2552 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2554 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2556 let iiptvirgb = tuple_of_list1 iiptvirg
in
2558 (match onefield_multivars
with
2559 | [] -> raise Impossible
2560 | [onevar
,iivirg
] ->
2561 assert (null iivirg
);
2563 | B.BitField
(sopt
, typb
, _
, expr
) ->
2564 pr2_once
"warning: bitfield not handled by ast_cocci";
2566 | B.Simple
(None
, typb
) ->
2567 pr2_once
"warning: unnamed struct field not handled by ast_cocci";
2569 | B.Simple
(Some nameidb
, typb
) ->
2571 (* build a declaration from a struct field *)
2572 let allminus = false in
2574 let stob = B.NoSto
, false in
2576 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2579 B.v_local
= Ast_c.NotLocalDecl
;
2580 B.v_attr
= Ast_c.noattr
;
2581 B.v_type_bis
= ref None
;
2582 (* the struct field should also get expanded ? no it's not
2583 * important here, we will rematch very soon *)
2587 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2588 (fun fa
(var
,iiptvirgb,iisto) ->
2591 | ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2596 let onevar = B.Simple
(Some nameidb
, typb
) in
2600 ((B.DeclarationField
2601 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2604 | _
-> raise Impossible
2609 pr2_once
"PB: More that one variable in decl. Have to split";
2612 | _
,B.EmptyField _iifield
->
2615 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2617 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2619 | _
,B.CppDirectiveStruct directive
-> fail
2620 | _
,B.IfdefStruct directive
-> fail
2623 and enum_fields
= fun eas ebs
->
2625 match A.unwrap ea
with
2626 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2628 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2629 let match_comma ea
=
2630 match A.unwrap ea
with
2631 A.EComma ia1
-> Some ia1
2633 let build_comma ia1
= A.EComma ia1
in
2634 let match_metalist ea
= None
in
2635 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
2636 let mktermval v = failwith
"not possible" in
2637 let special_cases ea
eas ebs
= None
in
2638 list_matcher match_dots build_dots match_comma build_comma
2639 match_metalist build_metalist mktermval
2640 special_cases enum_field
X.distrf_enum_fields
2641 Lib_parsing_c.ii_of_enum_fields
eas ebs
2643 and enum_field ida idb
=
2644 X.all_bound
(A.get_inherited ida
) >&&>
2645 match A.unwrap ida
, idb
with
2646 A.Ident
(id
),(nameidb
,None
) ->
2647 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2648 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2649 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2650 (match A.unwrap ea1
with
2652 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2653 expression ea2 eb2
>>= (fun ea2 eb2
->
2654 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2656 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2658 (nameidb
,Some
(opbi,eb2
))))))
2659 | _
-> failwith
"not possible")
2660 | _
-> failwith
"not possible"
2662 (* ------------------------------------------------------------------------- *)
2663 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2665 X.optional_qualifier_flag
(fun optional_qualifier
->
2666 X.all_bound
(A.get_inherited typa
) >&&>
2667 match A.unwrap typa
, typb
with
2668 | A.Type
(allminus,cv
,ty1
), ((qu
,il
),ty2
) ->
2670 if qu
.B.const
&& qu
.B.volatile
2673 ("warning: the type is both const & volatile but cocci " ^
2674 "does not handle that");
2676 (* Drop out the const/volatile part that has been matched.
2677 * This is because a SP can contain const T v; in which case
2678 * later in match_t_t when we encounter a T, we must not add in
2679 * the environment the whole type.
2684 (* "iso-by-absence" *)
2687 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1
((qu
,il
), ty2
) ->
2689 then minusize_list il
2690 else return ((), il
)
2693 (A.Type
(allminus, None
, ty1
)) +> A.rewrap typa
,
2697 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2698 | false, false -> do_stuff ()
2699 | false, true -> fail
2700 | true, false -> do_stuff ()
2703 then pr2_once
"USING optional_qualifier builtin isomorphism";
2709 (* todo: can be __const__ ? can be const & volatile so
2710 * should filter instead ?
2712 (match term x
, il
with
2713 | A.Const
, [i1
] when qu
.B.const
->
2715 tokenf x i1
>>= (fun x i1
->
2716 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2718 (A.Type
(allminus, Some x
, ty1
)) +> A.rewrap typa
,
2722 | A.Volatile
, [i1
] when qu
.B.volatile
->
2723 tokenf x i1
>>= (fun x i1
->
2724 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2726 (A.Type
(allminus, Some x
, ty1
)) +> A.rewrap typa
,
2734 | A.AsType
(ty
,asty
), tyb
->
2735 fullType ty tyb
>>= (fun ty tyb
->
2736 fullType asty tyb
>>= (fun asty tyb
->
2738 ((A.AsType
(ty
,asty
)) +> A.rewrap typa
,
2741 | A.DisjType typas
, typb
->
2743 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2745 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2746 -> failwith
"not handling Opt/Unique on type"
2751 * Why not (A.typeC, Ast_c.typeC) matcher ?
2752 * because when there is MetaType, we want that T record the whole type,
2753 * including the qualifier, and so this type (and the new_il function in
2754 * preceding function).
2757 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2759 X.all_bound
(A.get_inherited ta
) >&&>
2760 match A.unwrap ta
, tb
with
2763 | A.MetaType
(ida
,keep
, inherited
), typb
->
2765 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2766 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2767 X.distrf_type ida typb
>>= (fun ida typb
->
2769 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2773 | unwrap
, (qub
, typb
) ->
2774 typeC ta typb
>>= (fun ta typb
->
2775 return (ta
, (qub
, typb
))
2778 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2779 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2780 * And even if in baseb we have a Signed Int, that does not mean
2781 * that ii is of length 2, cos Signed is the default, so if in signa
2782 * we have Signed explicitly ? we cant "accrocher" this mcode to
2783 * something :( So for the moment when there is signed in cocci,
2784 * we force that there is a signed in c too (done in pattern.ml).
2786 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2789 (* handle some iso on type ? (cf complex C rule for possible implicit
2791 match basea
, baseb
with
2792 | A.VoidType
, B.Void
2793 | A.FloatType
, B.FloatType
(B.CFloat
)
2794 | A.DoubleType
, B.FloatType
(B.CDouble
)
2795 | A.SizeType
, B.SizeType
2796 | A.SSizeType
, B.SSizeType
2797 | A.PtrDiffType
,B.PtrDiffType
->
2798 assert (signaopt
=*= None
);
2799 let stringa = tuple_of_list1 stringsa
in
2800 let (ibaseb
) = tuple_of_list1 ii
in
2801 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2803 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2804 (B.BaseType baseb
, [ibaseb
])
2807 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2808 let stringa = tuple_of_list1 stringsa
in
2809 let ibaseb = tuple_of_list1 ii
in
2810 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2812 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2813 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2816 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2817 let stringa = tuple_of_list1 stringsa
in
2818 let ibaseb = tuple_of_list1 iibaseb
in
2819 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2820 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2822 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2823 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2826 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2827 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2828 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2829 let stringa = tuple_of_list1 stringsa
in
2832 (* iso-by-presence ? *)
2833 (* when unsigned int in SP, allow have just unsigned in C ? *)
2834 if mcode_contain_plus (mcodekind stringa)
2838 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2840 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2841 (B.BaseType
(baseb
), iisignbopt
++ [])
2847 "warning: long int or short int not handled by ast_cocci";*)
2851 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2852 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2854 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2855 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2857 | _
-> raise Impossible
2861 | A.LongLongIntType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2862 let (string1a
,string2a
,string3a
) = tuple_of_list3 stringsa
in
2864 [ibase1b
;ibase2b
;ibase3b
] ->
2865 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2866 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2867 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2868 tokenf string3a ibase3b
>>= (fun base3a ibase3b
->
2870 (rebuilda
([base1a
;base2a
;base3a
], signaopt
)) +> A.rewrap ta
,
2871 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
;ibase3b
])
2873 | [ibase1b
;ibase2b
] -> fail (* int omitted *)
2874 | [] -> fail (* should something be done in this case? *)
2875 | _
-> raise Impossible
)
2878 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
))
2879 | A.LongIntType
, B.IntType
(B.Si
(_
, B.CLong
))
2880 | A.ShortIntType
, B.IntType
(B.Si
(_
, B.CShort
))
2881 | A.LongDoubleType
, B.FloatType
B.CLongDouble
->
2882 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2884 [ibase1b
;ibase2b
] ->
2885 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2886 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2887 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2889 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2890 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2892 | [ibase1b
] -> fail (* short or long *)
2893 | [ibase1b
;ibase2b
;ibase3b
] -> fail (* long long case *)
2894 | [] -> fail (* should something be done in this case? *)
2895 | _
-> raise Impossible
)
2897 | _
, (B.Void
|B.FloatType _
|B.IntType _
2898 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2900 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2901 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2902 * And even if in baseb we have a Signed Int, that does not mean
2903 * that ii is of length 2, cos Signed is the default, so if in signa
2904 * we have Signed explicitely ? we cant "accrocher" this mcode to
2905 * something :( So for the moment when there is signed in cocci,
2906 * we force that there is a signed in c too (done in pattern.ml).
2908 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2910 let match_to_type rebaseb
=
2911 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2912 let fta = A.rewrap basea
(A.Type
(false(*don't know*),None
,basea
)) in
2913 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
2914 fullType
fta ftb >>= (fun fta (_
,tb
) ->
2915 (match A.unwrap
fta,tb
with
2916 A.Type
(_
,_
,basea
), (B.BaseType baseb
, ii
) ->
2918 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
2919 (B.BaseType
(baseb
), iisignbopt
++ ii
)
2921 | _
-> failwith
"not possible"))) in
2923 (* handle some iso on type ? (cf complex C rule for possible implicit
2926 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
2927 match_to_type (B.IntType
B.CChar
)
2929 | B.IntType
(B.Si
(_
, ty
)) ->
2931 | [] -> fail (* metavariable has to match something *)
2933 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
2937 | (B.Void
|B.FloatType _
|B.IntType _
2938 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2940 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
2942 match A.unwrap ta
, tb
with
2943 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
2944 simulate_signed ta basea stringsa None tb baseb ii
2945 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
2946 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
2947 (match A.unwrap basea
with
2948 A.BaseType
(basea1
,strings1
) ->
2949 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
2950 (function (strings1
, Some signaopt
) ->
2953 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
2954 | _
-> failwith
"not possible")
2955 | A.MetaType
(ida
,keep
,inherited
) ->
2956 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
2957 (function (basea
, Some signaopt
) ->
2958 A.SignedT
(signaopt
,Some basea
)
2959 | _
-> failwith
"not possible")
2960 | _
-> failwith
"not possible")
2961 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
2962 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2963 (match iibaseb
, baseb
with
2964 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
2965 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
2967 | None
-> raise Impossible
2970 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
2971 (B.BaseType baseb
, iisignbopt
)
2979 (* todo? iso with array *)
2980 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
2981 let (ibmult
) = tuple_of_list1 ii
in
2982 fullType typa typb
>>= (fun typa typb
->
2983 tokenf iamult ibmult
>>= (fun iamult ibmult
->
2985 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
2986 (B.Pointer typb
, [ibmult
])
2989 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
2990 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
2992 let (lpb
, rpb
) = tuple_of_list2 ii
in
2996 ("Not handling well variable length arguments func. "^
2997 "You have been warned");
2998 tokenf lpa lpb
>>= (fun lpa lpb
->
2999 tokenf rpa rpb
>>= (fun rpa rpb
->
3000 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
3001 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
3002 (fun paramsaundots paramsb
->
3003 let paramsa = redots
paramsa paramsaundots
in
3005 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
3006 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
3014 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
3015 (B.ParenType t1
, ii
) ->
3016 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
3017 let (qu1b
, t1b
) = t1
in
3019 | B.Pointer t2
, ii
->
3020 let (starb
) = tuple_of_list1 ii
in
3021 let (qu2b
, t2b
) = t2
in
3023 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
3024 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
3029 ("Not handling well variable length arguments func. "^
3030 "You have been warned");
3032 fullType tya tyb
>>= (fun tya tyb
->
3033 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
3034 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
3035 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
3036 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
3037 tokenf stara starb
>>= (fun stara starb
->
3038 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
3039 (fun paramsaundots paramsb
->
3040 let paramsa = redots
paramsa paramsaundots
in
3044 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
3049 (B.Pointer
t2, [starb
]))
3053 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
3055 (B.ParenType
t1, [lp1b
;rp1b
])
3068 (* todo: handle the iso on optional size specification ? *)
3069 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
3070 let (ib1, ib2
) = tuple_of_list2 ii
in
3071 fullType typa typb
>>= (fun typa typb
->
3072 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
3073 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3074 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3076 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
3077 (B.Array
(ebopt
, typb
), [ib1;ib2
])
3081 (* todo: could also match a Struct that has provided a name *)
3082 (* This is for the case where the SmPL code contains "struct x", without
3083 a definition. In this case, the name field is always present.
3084 This case is also called from the case for A.StructUnionDef when
3085 a name is present in the C code. *)
3086 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
3087 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
3088 let (ib1, ib2
) = tuple_of_list2 ii
in
3089 if equal_structUnion (term sua
) sub
3091 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
3092 tokenf sua
ib1 >>= (fun sua
ib1 ->
3094 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
3095 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
3100 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
3101 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
3103 let (ii_sub_sb
, lbb
, rbb
) =
3105 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
3106 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
3107 | _
-> error ii
"list of length 3 or 4 expected" in
3110 match (sbopt
,ii_sub_sb
) with
3111 (None
,Common.Left iisub
) ->
3112 (* the following doesn't reconstruct the complete SP code, just
3113 the part that matched *)
3115 match A.unwrap
s with
3116 A.Type
(allminus,None
,ty
) ->
3117 (match A.unwrap ty
with
3118 A.StructUnionName
(sua
, None
) ->
3119 (match (term sua
, sub
) with
3121 | (A.Union
,B.Union
) -> return ((),())
3124 tokenf sua iisub
>>= (fun sua iisub
->
3126 A.Type
(allminus,None
,
3127 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
3129 return (ty,[iisub
])))
3131 | A.DisjType
(disjs
) ->
3133 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3137 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3139 (* build a StructUnionName from a StructUnion *)
3140 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
3142 fullType
ty fake_su >>= (fun ty fake_su ->
3144 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
3145 return (ty, [iisub
; iisb
])
3146 | _
-> raise Impossible
)
3150 >>= (fun ty ii_sub_sb
->
3152 tokenf lba lbb
>>= (fun lba lbb
->
3153 tokenf rba rbb
>>= (fun rba rbb
->
3154 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
3155 let declsa = redots
declsa undeclsa
in
3158 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
3159 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
3163 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
3164 * uint in the C code. But some CEs consists in renaming some types,
3165 * so we don't want apply isomorphisms every time.
3167 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3171 | B.RegularName
(sb
, iidb
) ->
3172 let iidb1 = tuple_of_list1 iidb
in
3176 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3178 (A.TypeName sa
) +> A.rewrap ta
,
3179 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3183 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3188 | _
, (B.NoType
, ii
) -> fail
3189 | _
, (B.TypeOfExpr e
, ii
) -> fail
3190 | _
, (B.TypeOfType e
, ii
) -> fail
3192 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3193 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3194 let (ib1,ib2
) = tuple_of_list2 ii
in
3195 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3196 tokenf en
ib1 >>= (fun en
ib1 ->
3198 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3199 (B.EnumName nameb
, [ib1;ib2
])
3202 | A.EnumDef
(ty, lba
, idsa
, rba
),
3203 (B.Enum
(sbopt
, idsb
), ii
) ->
3205 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3207 [iisub
; lbb
; rbb
; comma_opt
] ->
3208 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3209 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3210 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3211 | _
-> error ii
"list of length 4 or 5 expected" in
3214 match (sbopt
,ii_sub_sb
) with
3215 (None
,Common.Left iisub
) ->
3216 (* the following doesn't reconstruct the complete SP code, just
3217 the part that matched *)
3219 match A.unwrap
s with
3220 A.Type
(allminus,None
,ty) ->
3221 (match A.unwrap
ty with
3222 A.EnumName
(sua
, None
) ->
3223 tokenf sua iisub
>>= (fun sua iisub
->
3225 A.Type
(allminus,None
,A.EnumName
(sua
, None
) +>
3228 return (ty,[iisub
]))
3230 | A.DisjType
(disjs
) ->
3232 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3236 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3238 (* build an EnumName from an Enum *)
3239 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3241 fullType
ty fake_su >>= (fun ty fake_su ->
3243 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3244 return (ty, [iisub
; iisb
])
3245 | _
-> raise Impossible
)
3249 >>= (fun ty ii_sub_sb
->
3251 tokenf lba lbb
>>= (fun lba lbb
->
3252 tokenf rba rbb
>>= (fun rba rbb
->
3253 let idsb = resplit_initialiser idsb [comma_opt
] in
3257 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3259 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3260 let idsa = redots
idsa unidsa
in
3262 match List.rev
idsb with
3263 (Right comma
)::rest ->
3264 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3265 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3268 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3269 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3273 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3276 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3277 B.StructUnion
(_
, _
, _
) |
3278 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3284 (* todo: iso on sign, if not mentioned then free. tochange?
3285 * but that require to know if signed int because explicit
3286 * signed int, or because implicit signed int.
3289 and sign signa signb
=
3290 match signa
, signb
with
3291 | None
, None
-> return (None
, [])
3292 | Some signa
, Some
(signb
, ib
) ->
3293 if equal_sign (term signa
) signb
3294 then tokenf signa ib
>>= (fun signa ib
->
3295 return (Some signa
, [ib
])
3301 and minusize_list iixs
=
3302 iixs
+> List.fold_left
(fun acc ii
->
3303 acc
>>= (fun xs ys
->
3304 tokenf minusizer ii
>>= (fun minus ii
->
3305 return (minus
::xs
, ii
::ys
)
3306 ))) (return ([],[]))
3307 >>= (fun _xsminys ys
->
3308 return ((), List.rev ys
)
3311 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3312 (* "iso-by-absence" for storage, and return type. *)
3313 X.optional_storage_flag
(fun optional_storage
->
3314 match stoa
, stob with
3315 | None
, (stobis
, inline
) ->
3319 minusize_list iistob
>>= (fun () iistob
->
3320 return (None
, (stob, iistob
))
3322 else return (None
, (stob, iistob
))
3325 (match optional_storage
, stobis
with
3326 | false, B.NoSto
-> do_minus ()
3328 | true, B.NoSto
-> do_minus ()
3331 then pr2_once
"USING optional_storage builtin isomorphism";
3335 | Some x
, ((stobis
, inline
)) ->
3336 if equal_storage (term x
) stobis
3338 let rec loop acc
= function
3341 let str = B.str_of_info i1
in
3343 "static" | "extern" | "auto" | "register" ->
3344 (* not very elegant, but tokenf doesn't know what token to
3346 tokenf x i1
>>= (fun x i1
->
3347 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3348 return (Some x
, ((stobis
, inline
), rebuilt)))
3349 | _
-> loop (i1
::acc
) iistob
) in
3354 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3355 (* "iso-by-absence" for storage, and return type. *)
3356 X.optional_storage_flag
(fun optional_storage
->
3357 match inla
, stob with
3358 | None
, (stobis
, inline
) ->
3362 minusize_list iistob
>>= (fun () iistob
->
3363 return (None
, (stob, iistob
))
3365 else return (None
, (stob, iistob
))
3374 then pr2_once
"USING optional_storage builtin isomorphism";
3377 else fail (* inline not in SP and present in C code *)
3380 | Some x
, ((stobis
, inline
)) ->
3383 let rec loop acc
= function
3386 let str = B.str_of_info i1
in
3389 (* not very elegant, but tokenf doesn't know what token to
3391 tokenf x i1
>>= (fun x i1
->
3392 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3393 return (Some x
, ((stobis
, inline
), rebuilt)))
3394 | _
-> loop (i1
::acc
) iistob
) in
3396 else fail (* SP has inline, but the C code does not *)
3399 and fullType_optional_allminus
allminus tya retb
=
3404 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3408 else return (None
, retb
)
3410 fullType tya retb
>>= (fun tya retb
->
3411 return (Some tya
, retb
)
3416 (*---------------------------------------------------------------------------*)
3418 and compatible_base_type a signa b
=
3419 let ok = return ((),()) in
3422 | Type_cocci.VoidType
, B.Void
3423 | Type_cocci.SizeType
, B.SizeType
3424 | Type_cocci.SSizeType
, B.SSizeType
3425 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3426 assert (signa
=*= None
);
3428 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3430 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3431 compatible_sign signa signb
3432 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3433 compatible_sign signa signb
3434 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3435 compatible_sign signa signb
3436 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3437 compatible_sign signa signb
3438 | Type_cocci.LongLongType
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3439 compatible_sign signa signb
3440 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3441 assert (signa
=*= None
);
3443 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3444 assert (signa
=*= None
);
3446 | _
, B.FloatType
B.CLongDouble
->
3447 pr2_once
"no longdouble in cocci";
3449 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3451 | _
, (B.Void
|B.FloatType _
|B.IntType _
3452 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3454 and compatible_base_type_meta a signa qua b ii
local =
3456 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3457 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3458 compatible_sign signa signb
>>= fun _ _
->
3459 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3460 compatible_type a
newb
3461 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3462 compatible_sign signa signb
>>= fun _ _
->
3464 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3465 compatible_type a
newb
3466 | _
, B.FloatType
B.CLongDouble
->
3467 pr2_once
"no longdouble in cocci";
3470 | _
, (B.Void
|B.FloatType _
|B.IntType _
3471 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3474 and compatible_type a
(b
,local) =
3475 let ok = return ((),()) in
3477 let rec loop = function
3478 | _
, (qua
, (B.NoType
, _
)) ->
3479 failwith
"compatible_type: matching with NoType"
3480 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3481 compatible_base_type a None b
3483 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3484 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3486 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3488 Type_cocci.BaseType
ty ->
3489 compatible_base_type
ty (Some signa
) b
3490 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3491 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3492 | _
-> failwith
"not possible")
3494 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3496 | Type_cocci.FunctionPointer a
, _
->
3498 "TODO: function pointer type doesn't store enough information to determine compatibility"
3499 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3500 (* no size info for cocci *)
3502 | Type_cocci.StructUnionName
(sua
, name
),
3503 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3504 if equal_structUnion_type_cocci sua sub
3505 then structure_type_name name sb ii
3507 | Type_cocci.EnumName
(name
),
3508 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3509 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3510 let sb = Ast_c.str_of_name namesb
in
3515 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3516 if (fst qub
).B.const
&& (fst qub
).B.volatile
3519 pr2_once
("warning: the type is both const & volatile but cocci " ^
3520 "does not handle that");
3526 | Type_cocci.Const
-> (fst qub
).B.const
3527 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3529 then loop (a
,(Ast_c.nQ
, b
))
3532 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3534 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3535 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3539 (* subtil: must be after the MetaType case *)
3540 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3541 (* kind of typedef iso *)
3544 (* for metavariables of type expression *^* *)
3545 | Type_cocci.Unknown
, _
-> ok
3550 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3551 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3558 B.StructUnionName
(_
, _
)|
3560 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3565 and structure_type_name nm
sb ii
=
3567 Type_cocci.NoName
-> ok
3568 | Type_cocci.Name sa
->
3572 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3573 (* degenerate version of MetaId, no transformation possible *)
3574 let (ib1, ib2
) = tuple_of_list2 ii
in
3575 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3576 let mida = A.make_mcode ida
in
3577 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3583 and compatible_sign signa signb
=
3584 let ok = return ((),()) in
3585 match signa
, signb
with
3587 | Some
Type_cocci.Signed
, B.Signed
3588 | Some
Type_cocci.Unsigned
, B.UnSigned
3593 and equal_structUnion_type_cocci a b
=
3595 | Type_cocci.Struct
, B.Struct
-> true
3596 | Type_cocci.Union
, B.Union
-> true
3597 | _
, (B.Struct
| B.Union
) -> false
3601 (*---------------------------------------------------------------------------*)
3602 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3604 let rec aux_inc (ass
, bss
) passed
=
3608 let passed = List.rev
passed in
3610 (match before_after
, !h_rel_pos
with
3611 | IncludeNothing
, _
-> true
3612 | IncludeMcodeBefore
, Some x
->
3613 List.mem
passed (x
.Ast_c.first_of
)
3615 | IncludeMcodeAfter
, Some x
->
3616 List.mem
passed (x
.Ast_c.last_of
)
3618 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3622 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3623 | _
-> failwith
"IncDots not in last place or other pb"
3628 | A.Local ass
, B.Local bss
->
3629 aux_inc (ass
, bss
) []
3630 | A.NonLocal ass
, B.NonLocal bss
->
3631 aux_inc (ass
, bss
) []
3636 (*---------------------------------------------------------------------------*)
3638 and (define_params
: sequence
->
3639 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3640 fun seqstyle eas ebs
->
3642 | Unordered
-> failwith
"not handling ooo"
3644 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3645 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3648 (* todo? facto code with argument and parameters ? *)
3649 and define_paramsbis
= fun eas ebs
->
3651 match A.unwrap ea
with
3652 A.DPdots
(mcode) -> Some
(mcode, None
)
3654 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3655 let match_comma ea
=
3656 match A.unwrap ea
with
3657 A.DPComma ia1
-> Some ia1
3659 let build_comma ia1
= A.DPComma ia1
in
3660 let match_metalist ea
= None
in
3661 let build_metalist (ida
,leninfo
,keep
,inherited
) = failwith
"not possible" in
3662 let mktermval v = failwith
"not possible" in
3663 let special_cases ea
eas ebs
= None
in
3664 let no_ii x
= failwith
"not possible" in
3665 list_matcher match_dots build_dots match_comma build_comma
3666 match_metalist build_metalist mktermval
3667 special_cases define_parameter
X.distrf_define_params
no_ii eas ebs
3669 and define_parameter
= fun parama paramb
->
3670 match A.unwrap parama
, paramb
with
3671 A.DParam ida
, (idb
, ii
) ->
3672 let ib1 = tuple_of_list1 ii
in
3673 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3674 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3675 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3676 failwith
"handling Opt/Unique for define parameters"
3677 | A.DPcircles
(_
), ys
-> raise Impossible
(* in Ordered mode *)
3680 (*****************************************************************************)
3682 (*****************************************************************************)
3684 (* no global solution for positions here, because for a statement metavariable
3685 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3687 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3690 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3692 X.all_bound
(A.get_inherited re
) >&&>
3695 match A.unwrap re
, F.unwrap node
with
3697 (* note: the order of the clauses is important. *)
3699 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3701 (* the metaRuleElem contains just '-' information. We dont need to add
3702 * stuff in the environment. If we need stuff in environment, because
3703 * there is a + S somewhere, then this will be done via MetaStmt, not
3705 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3708 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3709 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3710 (match unwrap_node
with
3712 | F.TrueNode
| F.FalseNode
| F.AfterNode
3713 | F.LoopFallThroughNode
| F.FallThroughNode
3715 if X.mode
=*= PatternMode
3718 if mcode_contain_plus (mcodekind mcode)
3719 then failwith
"try add stuff on fake node"
3720 (* minusize or contextize a fake node is ok *)
3723 | F.EndStatement None
->
3724 if X.mode
=*= PatternMode
then return default
3726 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3727 if mcode_contain_plus (mcodekind mcode)
3729 let fake_info = Ast_c.fakeInfo() in
3730 distrf distrf_node (mcodekind mcode)
3731 (F.EndStatement (Some fake_info))
3732 else return unwrap_node
3736 | F.EndStatement
(Some i1
) ->
3737 tokenf mcode i1
>>= (fun mcode i1
->
3739 A.MetaRuleElem
(mcode,keep
, inherited
),
3740 F.EndStatement
(Some i1
)
3744 if X.mode
=*= PatternMode
then return default
3745 else failwith
"a MetaRuleElem can't transform a headfunc"
3747 if X.mode
=*= PatternMode
then return default
3749 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3751 A.MetaRuleElem
(mcode,keep
, inherited
),
3757 (* rene cant have found that a state containing a fake/exit/... should be
3759 * TODO: and F.Fake ?
3761 | _
, F.EndStatement _
| _
, F.CaseNode _
3762 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3763 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3764 | _
, F.InLoopNode
-> fail2()
3766 (* really ? diff between pattern.ml and transformation.ml *)
3767 | _
, F.Fake
-> fail2()
3770 (* cas general: a Meta can match everything. It matches only
3771 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3772 * So can't have been called in transform.
3774 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3776 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3777 (* todo: should not happen in transform mode *)
3779 (match Control_flow_c.extract_fullstatement node
with
3782 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3783 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3785 (* no need tag ida, we can't be called in transform-mode *)
3787 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3795 | A.MetaStmtList _
, _
->
3796 failwith
"not handling MetaStmtList"
3798 | A.TopExp ea
, F.DefineExpr eb
->
3799 expression ea eb
>>= (fun ea eb
->
3805 | A.TopExp ea
, F.DefineType eb
->
3806 (match A.unwrap ea
with
3808 fullType ft eb
>>= (fun ft eb
->
3810 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3817 (* It is important to put this case before the one that fails because
3818 * of the lack of the counter part of a C construct in SmPL (for instance
3819 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3820 * yet certain constructs, those constructs may contain expression
3821 * that we still want and can transform.
3824 | A.Exp exp
, nodeb
->
3826 (* kind of iso, initialisation vs affectation *)
3828 match A.unwrap exp
, nodeb
with
3829 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3830 initialisation_to_affectation decl
+> F.rewrap node
3835 (* Now keep fullstatement inside the control flow node,
3836 * so that can then get in a MetaStmtVar the fullstatement to later
3837 * pp back when the S is in a +. But that means that
3838 * Exp will match an Ifnode even if there is no such exp
3839 * inside the condition of the Ifnode (because the exp may
3840 * be deeper, in the then branch). So have to not visit
3841 * all inside a node anymore.
3843 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3844 * fois le fullstatement et le partialstatement et appeler le
3845 * visiteur que sur le partialstatement.
3848 match Ast_cocci.get_pos re
with
3849 | None
-> expression
3853 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3854 let keep = Type_cocci.Unitary
in
3855 let inherited = false in
3856 let max_min _
= failwith
"no pos" in
3857 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3863 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3871 X.cocciTy fullType
ty node >>= (fun ty node ->
3878 | A.TopInit init
, nodeb
->
3879 X.cocciInit initialiser init
node >>= (fun init
node ->
3887 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3888 F.FunHeader
({B.f_name
= nameidb
;
3889 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3893 f_old_c_style
= oldstyle
;
3898 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3901 (* fninfoa records the order in which the SP specified the various
3902 information, but this isn't taken into account in the matching.
3903 Could this be a problem for transformation? *)
3906 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3907 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3909 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3910 with [A.FType
(t
)] -> Some t
| _
-> None
in
3913 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
3914 with [A.FInline
(i
)] -> Some i
| _
-> None
in
3916 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
3917 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
3920 | ioparenb
::icparenb
::iifakestart
::iistob
->
3922 (* maybe important to put ident as the first tokens to transform.
3923 * It's related to transform_proto. So don't change order
3926 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
3927 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
3928 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
3929 tokenf cparen icparenb
>>= (fun cparen icparenb
->
3930 parameters
(seqstyle paramsa)
3931 (A.undots
paramsa) paramsb
>>=
3932 (fun paramsaundots paramsb
->
3933 let paramsa = redots
paramsa paramsaundots
in
3934 inline_optional_allminus
allminus
3935 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
3936 storage_optional_allminus
allminus
3937 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
3942 ("Not handling well variable length arguments func. "^
3943 "You have been warned");
3945 then minusize_list iidotsb
3946 else return ((),iidotsb
)
3947 ) >>= (fun () iidotsb
->
3949 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
3952 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
3953 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
3954 (match tya with Some t
-> [A.FType t
] | None
-> [])
3959 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
3961 F.FunHeader
({B.f_name
= nameidb
;
3962 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3966 f_old_c_style
= oldstyle
; (* TODO *)
3968 ioparenb
::icparenb
::iifakestart
::iistob
)
3971 | _
-> raise Impossible
3974 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
3975 declaration
(mckstart
,allminus,decla
) declb
>>=
3976 (fun (mckstart
,allminus,decla
) declb
->
3978 A.Decl
(mckstart
,allminus,decla
),
3983 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
3984 tokenf mcode i1
>>= (fun mcode i1
->
3987 F.SeqStart
(st
, level
, i1
)
3990 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
3991 tokenf mcode i1
>>= (fun mcode i1
->
3994 F.SeqEnd
(level
, i1
)
3997 | A.ExprStatement
(Some ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
3998 let ib1 = tuple_of_list1 ii
in
3999 expression ea eb
>>= (fun ea eb
->
4000 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4002 A.ExprStatement
(Some ea
, ia1
),
4003 F.ExprStatement
(st
, (Some eb
, [ib1]))
4007 | A.ExprStatement
(None
, ia1
), F.ExprStatement
(st
, (None
, ii
)) ->
4008 let ib1 = tuple_of_list1 ii
in
4009 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4011 A.ExprStatement
(None
, ia1
),
4012 F.ExprStatement
(st
, (None
, [ib1]))
4017 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
4018 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4019 expression ea eb
>>= (fun ea eb
->
4020 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4021 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4022 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4024 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
4025 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
4028 | A.Else ia
, F.Else ib
->
4029 tokenf ia ib
>>= (fun ia ib
->
4030 return (A.Else ia
, F.Else ib
)
4033 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
4034 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4035 expression ea eb
>>= (fun ea eb
->
4036 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4037 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4038 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4040 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
4041 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
4044 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
4045 tokenf ia ib
>>= (fun ia ib
->
4050 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
4051 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
4052 expression ea eb
>>= (fun ea eb
->
4053 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4054 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4055 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4056 tokenf ia4 ib4
>>= (fun ia4 ib4
->
4058 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
4059 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
4061 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
4063 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4065 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
4066 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4067 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4068 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
4069 let eas = redots
eas easundots
in
4071 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
4072 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
4077 | A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
4078 F.ForHeader
(st
, (((eb1opt
,ib3s
), (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
4080 assert (null ib4vide
);
4081 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
4082 let ib3 = tuple_of_list1 ib3s
in
4083 let ib4 = tuple_of_list1 ib4s
in
4085 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4086 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4087 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
4088 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
4089 tokenf ia5 ib5
>>= (fun ia5 ib5
->
4090 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
4091 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
4092 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
4094 A.ForHeader
(ia1
, ia2
, ea1opt
, ia3
, ea2opt
, ia4
, ea3opt
, ia5
),
4095 F.ForHeader
(st
, (((eb1opt
,[ib3]), (eb2opt
,[ib4]), (eb3opt
,[])),
4101 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
4102 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
4103 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4104 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4105 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
4106 expression ea eb
>>= (fun ea eb
->
4108 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
4109 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
4112 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
4113 let (ib1, ib2
) = tuple_of_list2 ii
in
4114 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4115 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4118 F.Break
(st
, ((),[ib1;ib2
]))
4121 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
4122 let (ib1, ib2
) = tuple_of_list2 ii
in
4123 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4124 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4126 A.Continue
(ia1
, ia2
),
4127 F.Continue
(st
, ((),[ib1;ib2
]))
4130 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
4131 let (ib1, ib2
) = tuple_of_list2 ii
in
4132 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4133 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4135 A.Return
(ia1
, ia2
),
4136 F.Return
(st
, ((),[ib1;ib2
]))
4139 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
4140 let (ib1, ib2
) = tuple_of_list2 ii
in
4141 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4142 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4143 expression ea eb
>>= (fun ea eb
->
4145 A.ReturnExpr
(ia1
, ea
, ia2
),
4146 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
4151 | A.Include
(incla
,filea
),
4152 F.Include
{B.i_include
= (fileb
, ii
);
4153 B.i_rel_pos
= h_rel_pos
;
4154 B.i_is_in_ifdef
= inifdef
;
4157 assert (copt
=*= None
);
4159 let include_requirment =
4160 match mcodekind incla
, mcodekind filea
with
4161 | A.CONTEXT
(_
, A.BEFORE _
), _
->
4163 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
4169 let (inclb
, iifileb
) = tuple_of_list2 ii
in
4170 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
4172 tokenf incla inclb
>>= (fun incla inclb
->
4173 tokenf filea iifileb
>>= (fun filea iifileb
->
4175 A.Include
(incla
, filea
),
4176 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
4177 B.i_rel_pos
= h_rel_pos
;
4178 B.i_is_in_ifdef
= inifdef
;
4184 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
4185 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4186 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4187 tokenf undefa defineb
>>= (fun undefa defineb
->
4189 A.Undef
(undefa
,ida
),
4190 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
4195 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4196 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4197 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4198 tokenf definea defineb
>>= (fun definea defineb
->
4199 (match A.unwrap params
, defkind
with
4200 | A.NoParams
, B.DefineVar
->
4202 A.NoParams
+> A.rewrap params
,
4205 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4206 let (lpb
, rpb
) = tuple_of_list2 ii
in
4207 tokenf lpa lpb
>>= (fun lpa lpb
->
4208 tokenf rpa rpb
>>= (fun rpa rpb
->
4210 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4211 (fun easundots ebs
->
4212 let eas = redots
eas easundots
in
4214 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4215 B.DefineFunc
(ebs
,[lpb
;rpb
])
4219 ) >>= (fun params defkind
->
4221 A.DefineHeader
(definea
, ida
, params
),
4222 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4227 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4228 let (ib1, ib2
) = tuple_of_list2 ii
in
4229 tokenf def
ib1 >>= (fun def
ib1 ->
4230 tokenf colon ib2
>>= (fun colon ib2
->
4232 A.Default
(def
,colon
),
4233 F.Default
(st
, ((),[ib1;ib2
]))
4238 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4239 let (ib1, ib2
) = tuple_of_list2 ii
in
4240 tokenf case
ib1 >>= (fun case
ib1 ->
4241 expression ea eb
>>= (fun ea eb
->
4242 tokenf colon ib2
>>= (fun colon ib2
->
4244 A.Case
(case
,ea
,colon
),
4245 F.Case
(st
, (eb
,[ib1;ib2
]))
4248 (* only occurs in the predicates generated by asttomember *)
4249 | A.DisjRuleElem
eas, _
->
4251 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4252 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4254 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4256 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4257 let (ib2
) = tuple_of_list1 ii
in
4258 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4259 tokenf dd ib2
>>= (fun dd ib2
->
4262 F.Label
(st
,nameb
, ((),[ib2
]))
4265 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4266 let (ib1,ib3) = tuple_of_list2 ii
in
4267 tokenf goto
ib1 >>= (fun goto
ib1 ->
4268 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4269 tokenf sem
ib3 >>= (fun sem
ib3 ->
4271 A.Goto
(goto
,id
,sem
),
4272 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4275 (* have not a counter part in coccinelle, for the moment *)
4276 (* todo?: print a warning at least ? *)
4283 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4287 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4290 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4291 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4292 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4293 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4294 F.MacroIterHeader
(_
, _
)|
4295 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4296 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4297 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4298 F.Decl _
|F.FunHeader _
)