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.
33 module F
= Control_flow_c
35 module FlagM
= Flag_matcher
37 (*****************************************************************************)
39 (*****************************************************************************)
40 let pr2, pr2_once
= Common.mk_pr2_wrappers
FlagM.verbose_matcher
42 let (+++) a b
= match a
with Some x
-> Some x
| None
-> b
49 (Printf.sprintf
"%s: %d: %s"
50 (Ast_c.file_of_info ii
) (Ast_c.line_of_info ii
) str
)
52 (*****************************************************************************)
54 (*****************************************************************************)
56 type sequence
= Ordered
| Unordered
59 match A.unwrap eas
with
61 | A.CIRCLES _
-> Unordered
62 | A.STARS _
-> failwith
"not handling stars"
64 let (redots
: 'a
A.dots
-> 'a list
-> 'a
A.dots
)=fun eas easundots
->
66 match A.unwrap eas
with
67 | A.DOTS _
-> A.DOTS easundots
68 | A.CIRCLES _
-> A.CIRCLES easundots
69 | A.STARS _
-> A.STARS easundots
73 let (need_unordered_initialisers
: B.initialiser
B.wrap2 list
-> bool) =
75 ibs
+> List.exists
(fun (ib
, icomma
) ->
76 match B.unwrap ib
with
85 (* For the #include <linux/...> in the .cocci, need to find where is
86 * the '+' attached to this element, to later find the first concrete
87 * #include <linux/xxx.h> or last one in the series of #includes in the
90 type include_requirement
=
97 (* todo? put in semantic_c.ml *)
100 | LocalFunction
(* entails Function *)
104 let term mc
= A.unwrap_mcode mc
105 let mcodekind mc
= A.get_mcodekind mc
108 let mcode_contain_plus = function
109 | A.CONTEXT
(_
,A.NOTHING
) -> false
110 | A.CONTEXT _
-> true
111 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> false
112 | A.MINUS
(_
,_
,_
,A.REPLACEMENT _
) -> true (* repl is nonempty *)
113 | A.PLUS _
-> raise
(Impossible
13)
115 let mcode_simple_minus = function
116 | A.MINUS
(_
,_
,_
,A.NOREPLACEMENT
) -> true
120 (* In transformation.ml sometime I build some mcodekind myself and
121 * julia has put None for the pos. But there is no possible raise
122 * NoMatch in those cases because it is for the minusall trick or for
123 * the distribute, so either have to build those pos, in fact a range,
124 * because for the distribute have to erase a fullType with one
125 * mcodekind, or add an argument to tag_with_mck such as "safe" that
126 * don't do the check_pos. Hence this DontCarePos constructor. *)
130 {A.line
= 0; A.column
=0; A.strbef
=[]; A.straft
=[]},
131 (A.MINUS
(A.DontCarePos
,[],A.ALLMINUS
,A.NOREPLACEMENT
)),
134 let generalize_mcode ia
=
135 let (s1
, i
, mck
, pos
) = ia
in
138 | A.PLUS _
-> raise
(Impossible
14)
139 | A.CONTEXT
(A.NoPos
,x
) ->
140 A.CONTEXT
(A.DontCarePos
,x
)
141 | A.MINUS
(A.NoPos
,inst
,adj
,x
) ->
142 A.MINUS
(A.DontCarePos
,inst
,adj
,x
)
144 | A.CONTEXT
((A.FixPos _
|A.DontCarePos
), _
)
145 | A.MINUS
((A.FixPos _
|A.DontCarePos
), _
, _
, _
)
147 raise
(Impossible
15)
149 (s1
, i
, new_mck, pos
)
153 (*---------------------------------------------------------------------------*)
155 (* 0x0 is equivalent to 0, value format isomorphism *)
156 let equal_c_int s1 s2
=
158 int_of_string s1
=|= int_of_string s2
159 with Failure
("int_of_string") ->
164 (*---------------------------------------------------------------------------*)
165 (* Normally A should reuse some types of Ast_c, so those
166 * functions should not exist.
168 * update: but now Ast_c depends on A, so can't make too
169 * A depends on Ast_c, so have to stay with those equal_xxx
173 let equal_unaryOp a b
=
175 | A.GetRef
, B.GetRef
-> true
176 | A.GetRefLabel
, B.GetRefLabel
-> true
177 | A.DeRef
, B.DeRef
-> true
178 | A.UnPlus
, B.UnPlus
-> true
179 | A.UnMinus
, B.UnMinus
-> true
180 | A.Tilde
, B.Tilde
-> true
181 | A.Not
, B.Not
-> true
182 | _
, (B.Not
|B.Tilde
|B.UnMinus
|B.UnPlus
|B.DeRef
|B.GetRef
|B.GetRefLabel
) ->
187 let equal_arithOp a b
=
189 | A.Plus
, B.Plus
-> true
190 | A.Minus
, B.Minus
-> true
191 | A.Mul
, B.Mul
-> true
192 | A.Div
, B.Div
-> true
193 | A.Mod
, B.Mod
-> true
194 | A.DecLeft
, B.DecLeft
-> true
195 | A.DecRight
, B.DecRight
-> true
196 | A.And
, B.And
-> true
197 | A.Or
, B.Or
-> true
198 | A.Xor
, B.Xor
-> true
199 | A.Min
, B.Min
-> true
200 | A.Max
, B.Max
-> true
201 | _
, (B.Xor
|B.Or
|B.And
|B.DecRight
|B.DecLeft
|B.Mod
|B.Div
|B.Mul
|B.Minus
|B.Plus
|B.Min
|B.Max
)
204 let equal_logicalOp a b
=
206 | A.Inf
, B.Inf
-> true
207 | A.Sup
, B.Sup
-> true
208 | A.InfEq
, B.InfEq
-> true
209 | A.SupEq
, B.SupEq
-> true
210 | A.Eq
, B.Eq
-> true
211 | A.NotEq
, B.NotEq
-> true
212 | A.AndLog
, B.AndLog
-> true
213 | A.OrLog
, B.OrLog
-> true
214 | _
, (B.OrLog
|B.AndLog
|B.NotEq
|B.Eq
|B.SupEq
|B.InfEq
|B.Sup
|B.Inf
)
217 let equal_assignOp a b
=
219 | A.SimpleAssign
, B.SimpleAssign
-> true
220 | A.OpAssign a
, B.OpAssign b
-> equal_arithOp a b
221 | _
, (B.OpAssign _
|B.SimpleAssign
) -> false
223 let equal_fixOp a b
=
225 | A.Dec
, B.Dec
-> true
226 | A.Inc
, B.Inc
-> true
227 | _
, (B.Inc
|B.Dec
) -> false
229 let equal_binaryOp a b
=
231 | A.Arith a
, B.Arith b
-> equal_arithOp a b
232 | A.Logical a
, B.Logical b
-> equal_logicalOp a b
233 | _
, (B.Logical _
| B.Arith _
) -> false
235 let equal_structUnion a b
=
237 | A.Struct
, B.Struct
-> true
238 | A.Union
, B.Union
-> true
239 | _
, (B.Struct
|B.Union
) -> false
243 | A.Signed
, B.Signed
-> true
244 | A.Unsigned
, B.UnSigned
-> true
245 | _
, (B.UnSigned
|B.Signed
) -> false
247 let equal_storage a b
=
249 | A.Static
, B.Sto
B.Static
250 | A.Auto
, B.Sto
B.Auto
251 | A.Register
, B.Sto
B.Register
252 | A.Extern
, B.Sto
B.Extern
254 | _
, (B.NoSto
| B.StoTypedef
) -> false
255 | _
, (B.Sto
(B.Register
|B.Static
|B.Auto
|B.Extern
)) -> false
258 (*---------------------------------------------------------------------------*)
260 let equal_metavarval valu valu'
=
261 match valu
, valu'
with
262 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
263 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
264 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
265 (* do something more ? *)
268 (* al_expr before comparing !!! and accept when they match.
269 * Note that here we have Astc._expression, so it is a match
270 * modulo isomorphism (there is no metavariable involved here,
271 * just isomorphisms). => TODO call isomorphism_c_c instead of
272 * =*=. Maybe would be easier to transform ast_c in ast_cocci
273 * and call the iso engine of julia. *)
274 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
275 Lib_parsing_c.al_expr a
=*= Lib_parsing_c.al_expr b
276 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
277 Lib_parsing_c.al_arguments a
=*= Lib_parsing_c.al_arguments b
279 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
280 Lib_parsing_c.al_declaration a
=*= Lib_parsing_c.al_declaration b
281 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
282 Lib_parsing_c.al_field a
=*= Lib_parsing_c.al_field b
283 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
284 Lib_parsing_c.al_fields a
=*= Lib_parsing_c.al_fields b
285 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
286 Lib_parsing_c.al_statement a
=*= Lib_parsing_c.al_statement b
287 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
288 Lib_parsing_c.al_init a
=*= Lib_parsing_c.al_init b
289 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
290 Lib_parsing_c.al_inits a
=*= Lib_parsing_c.al_inits b
291 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
292 (* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
295 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
297 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
298 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
299 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
300 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
302 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
303 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
305 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
307 (function (fla
,cea
,posa1
,posa2
) ->
309 (function (flb
,ceb
,posb1
,posb2
) ->
310 fla
=$
= flb
&& cea
=$
= ceb
&&
311 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
315 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
316 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
317 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
318 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
319 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
321 -> raise
(Impossible
16)
323 (* probably only one argument needs to be stripped, because inherited
324 metavariables containing expressions are stripped in advance. But don't
325 know which one is which... *)
326 let equal_inh_metavarval valu valu'
=
327 match valu
, valu'
with
328 | Ast_c.MetaIdVal
(a
,_
), Ast_c.MetaIdVal
(b
,_
) -> a
=$
= b
329 | Ast_c.MetaFuncVal a
, Ast_c.MetaFuncVal b
-> a
=$
= b
330 | Ast_c.MetaLocalFuncVal a
, Ast_c.MetaLocalFuncVal b
->
331 (* do something more ? *)
334 (* al_expr before comparing !!! and accept when they match.
335 * Note that here we have Astc._expression, so it is a match
336 * modulo isomorphism (there is no metavariable involved here,
337 * just isomorphisms). => TODO call isomorphism_c_c instead of
338 * =*=. Maybe would be easier to transform ast_c in ast_cocci
339 * and call the iso engine of julia. *)
340 | Ast_c.MetaExprVal
(a
,_
), Ast_c.MetaExprVal
(b
,_
) ->
341 Lib_parsing_c.al_inh_expr a
=*= Lib_parsing_c.al_inh_expr b
342 | Ast_c.MetaExprListVal a
, Ast_c.MetaExprListVal b
->
343 Lib_parsing_c.al_inh_arguments a
=*= Lib_parsing_c.al_inh_arguments b
345 | Ast_c.MetaDeclVal a
, Ast_c.MetaDeclVal b
->
346 Lib_parsing_c.al_inh_declaration a
=*= Lib_parsing_c.al_inh_declaration b
347 | Ast_c.MetaFieldVal a
, Ast_c.MetaFieldVal b
->
348 Lib_parsing_c.al_inh_field a
=*= Lib_parsing_c.al_inh_field b
349 | Ast_c.MetaFieldListVal a
, Ast_c.MetaFieldListVal b
->
350 Lib_parsing_c.al_inh_field_list a
=*= Lib_parsing_c.al_inh_field_list b
351 | Ast_c.MetaStmtVal a
, Ast_c.MetaStmtVal b
->
352 Lib_parsing_c.al_inh_statement a
=*= Lib_parsing_c.al_inh_statement b
353 | Ast_c.MetaInitVal a
, Ast_c.MetaInitVal b
->
354 Lib_parsing_c.al_inh_init a
=*= Lib_parsing_c.al_inh_init b
355 | Ast_c.MetaInitListVal a
, Ast_c.MetaInitListVal b
->
356 Lib_parsing_c.al_inh_inits a
=*= Lib_parsing_c.al_inh_inits b
357 | Ast_c.MetaTypeVal a
, Ast_c.MetaTypeVal b
->
358 (* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
361 | Ast_c.MetaListlenVal a
, Ast_c.MetaListlenVal b
-> a
=|= b
363 | Ast_c.MetaParamVal a
, Ast_c.MetaParamVal b
->
364 Lib_parsing_c.al_param a
=*= Lib_parsing_c.al_param b
365 | Ast_c.MetaParamListVal a
, Ast_c.MetaParamListVal b
->
366 Lib_parsing_c.al_params a
=*= Lib_parsing_c.al_params b
368 | Ast_c.MetaPosVal
(posa1
,posa2
), Ast_c.MetaPosVal
(posb1
,posb2
) ->
369 Ast_cocci.equal_pos posa1 posb1
&& Ast_cocci.equal_pos posa2 posb2
371 | Ast_c.MetaPosValList l1
, Ast_c.MetaPosValList l2
->
373 (function (fla
,cea
,posa1
,posa2
) ->
375 (function (flb
,ceb
,posb1
,posb2
) ->
376 fla
=$
= flb
&& cea
=$
= ceb
&&
377 Ast_c.equal_posl posa1 posb1
&& Ast_c.equal_posl posa2 posb2
)
381 | (B.MetaPosValList _
|B.MetaListlenVal _
|B.MetaPosVal _
|B.MetaStmtVal _
382 |B.MetaDeclVal _
|B.MetaFieldVal _
|B.MetaFieldListVal _
383 |B.MetaTypeVal _
|B.MetaInitVal _
|B.MetaInitListVal _
384 |B.MetaParamListVal _
|B.MetaParamVal _
|B.MetaExprListVal _
385 |B.MetaExprVal _
|B.MetaLocalFuncVal _
|B.MetaFuncVal _
|B.MetaIdVal _
387 -> raise
(Impossible
17)
390 (*---------------------------------------------------------------------------*)
391 (* could put in ast_c.ml, next to the split/unsplit_comma *)
392 let split_signb_baseb_ii (baseb
, ii
) =
393 let iis = ii
+> List.map
(fun info
-> (B.str_of_info info
), info
) in
394 match baseb
, iis with
396 | B.Void
, ["void",i1
] -> None
, [i1
]
398 | B.FloatType
(B.CFloat
),["float",i1
] -> None
, [i1
]
399 | B.FloatType
(B.CDouble
),["double",i1
] -> None
, [i1
]
400 | B.FloatType
(B.CLongDouble
),["long",i1
;"double",i2
] -> None
,[i1
;i2
]
402 | B.IntType
(B.CChar
), ["char",i1
] -> None
, [i1
]
405 | B.IntType
(B.Si
(sign
, base
)), xs
->
409 | (B.Signed
,(("signed",i1
)::rest
)) -> (Some
(B.Signed
,i1
),rest
)
410 | (B.Signed
,rest
) -> (None
,rest
)
411 | (B.UnSigned
,(("unsigned",i1
)::rest
)) -> (Some
(B.UnSigned
,i1
),rest
)
412 | (B.UnSigned
,rest
) -> (* is this case possible? *) (None
,rest
) in
413 (* The original code only allowed explicit signed and unsigned for char,
414 while this code allows char by itself. Not sure that needs to be
415 checked for here. If it does, then add a special case. *)
417 match (base
,rest
) with
418 B.CInt
, ["int",i1
] -> [i1
]
421 | B.CInt
, ["",i1
] -> (* no type is specified at all *)
422 (match i1
.B.pinfo
with
424 | _
-> error [i1
] ("unrecognized signed int: "^
425 (String.concat
" "(List.map fst
iis))))
427 | B.CChar2
, ["char",i2
] -> [i2
]
429 | B.CShort
, ["short",i1
] -> [i1
]
430 | B.CShort
, ["short",i1
;"int",i2
] -> [i1
;i2
]
432 | B.CLong
, ["long",i1
] -> [i1
]
433 | B.CLong
, ["long",i1
;"int",i2
] -> [i1
;i2
]
435 | B.CLongLong
, ["long",i1
;"long",i2
] -> [i1
;i2
]
436 | B.CLongLong
, ["long",i1
;"long",i2
;"int",i3
] -> [i1
;i2
;i3
]
439 error (List.map snd
iis)
440 ("strange type1, maybe because of weird order: "^
441 (String.concat
" " (List.map fst
iis))) in
444 | B.SizeType
, ["size_t",i1
] -> None
, [i1
]
445 | B.SSizeType
, ["ssize_t",i1
] -> None
, [i1
]
446 | B.PtrDiffType
, ["ptrdiff_t",i1
] -> None
, [i1
]
449 error (List.map snd
iis)
450 ("strange type2, maybe because of weird order: "^
451 (String.concat
" " (List.map fst
iis)))
453 (*---------------------------------------------------------------------------*)
455 let rec unsplit_icomma xs
=
459 (match A.unwrap y
with
461 (x
, y
)::unsplit_icomma xs
462 | _
-> failwith
"wrong ast_cocci in initializer"
465 failwith
("wrong ast_cocci in initializer, should have pair " ^
470 let resplit_initialiser ibs iicomma
=
471 match iicomma
, ibs
with
474 failwith
"should have a iicomma, do you generate fakeInfo in parser?"
476 error iicommas
"shouldn't have a iicomma"
477 | [iicomma
], x
::xs
->
478 let elems = List.map fst
(x
::xs
) in
479 let commas = List.map snd
(x
::xs
) +> List.flatten
in
480 let commas = commas @ [iicomma
] in
482 | _
-> raise
(Impossible
18)
486 let rec split_icomma xs
=
489 | (x
,y
)::xs
-> x
::y
::split_icomma xs
491 let rec unsplit_initialiser ibs_unsplit
=
492 match ibs_unsplit
with
493 | [] -> [], [] (* empty iicomma *)
495 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
496 (x
, [])::xs
, lastcomma
498 and unsplit_initialiser_bis comma_before
= function
499 | [] -> [], [comma_before
]
501 let (xs
, lastcomma
) = unsplit_initialiser_bis commax xs
in
502 (x
, [comma_before
])::xs
, lastcomma
507 (*---------------------------------------------------------------------------*)
508 (* coupling: same in type_annotater_c.ml *)
509 let structdef_to_struct_name ty
=
511 | qu
, (B.StructUnion
(su
, sopt
, fields
), iis) ->
513 | Some s
, [i1
;i2
;i3
;i4
] ->
514 qu
, (B.StructUnionName
(su
, s
), [i1
;i2
])
518 | x
-> raise
(Impossible
19)
520 | _
-> raise
(Impossible
20)
522 (*---------------------------------------------------------------------------*)
523 let one_initialisation_to_affectation x
=
524 let ({B.v_namei
= var
;
525 B.v_type
= returnType
;
526 B.v_type_bis
= tybis
;
527 B.v_storage
= storage
;
531 | Some
(name
, iniopt
) ->
533 | B.ValInit
(iini
, (B.InitExpr e
, ii_empty2
)) ->
536 Ast_c.NotLocalDecl
-> Ast_c.NotLocalVar
538 (match Ast_c.info_of_type returnType
with
539 None
-> failwith
"no returnType info"
540 | Some ii
-> Ast_c.LocalVar ii
) in
542 (* old: Lib_parsing_c.al_type returnType
543 * but this type has not the typename completed so
544 * instead try to use tybis
547 | Some ty_with_typename_completed
-> ty_with_typename_completed
548 | None
-> raise
(Impossible
21)
551 let typ = ref (Some
(typexp,local), Ast_c.NotTest
) in
553 let idexpr = Ast_c.mk_e_bis
(B.Ident
ident) typ Ast_c.noii
in
555 Ast_c.mk_e
(B.Assignment
(idexpr,B.SimpleAssign
, e
)) [iini
] in
560 let initialisation_to_affectation decl
=
562 | B.MacroDecl _
-> F.Decl decl
563 | B.MacroDeclInit _
-> F.Decl decl
(* not sure... *)
564 | B.DeclList
(xs
, iis) ->
566 (* todo?: should not do that if the variable is an array cos
567 * will have x[] = , mais de toute facon ca sera pas un InitExp
569 let possible_assignment =
573 match prev
,one_initialisation_to_affectation x
with
575 | None
,Some x
-> Some x
576 | Some prev
,Some x
->
577 (* [] is clearly an invalid ii value for a sequence.
578 hope that no one looks at it, since nothing will
579 match the sequence. Fortunately, SmPL doesn't
580 support , expressions. *)
581 Some
(Ast_c.mk_e
(Ast_c.Sequence
(prev
, x
)) []))
583 match possible_assignment with
584 Some x
-> F.DefineExpr x
585 | None
-> F.Decl decl
587 (*****************************************************************************)
588 (* Functor parameter combinators *)
589 (*****************************************************************************)
591 * src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
593 * version0: was not tagging the SP, so just tag the C
595 * (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
596 * val return : 'b -> tin -> 'b tout
597 * val fail : tin -> 'b tout
599 * version1: now also tag the SP so return a ('a * 'b)
602 type mode
= PatternMode
| TransformMode
610 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
615 (tin
-> ('a
* 'b
) tout
) ->
616 ('a
-> 'b
-> (tin
-> ('c
* 'd
) tout
)) ->
617 (tin
-> ('c
* 'd
) tout
)
619 val return
: ('a
* 'b
) -> tin
-> ('a
*'b
) tout
620 val fail
: tin
-> ('a
* 'b
) tout
632 val (>&&>) : (tin
-> bool) -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
634 val tokenf
: ('a
A.mcode
, B.info
) matcher
635 val tokenf_mck
: (A.mcodekind, B.info
) matcher
638 (A.meta_name
A.mcode
, B.expression
) matcher
640 (A.meta_name
A.mcode
, (Ast_c.argument
, Ast_c.il
) either list
) matcher
642 (A.meta_name
A.mcode
, Ast_c.fullType
) matcher
644 (A.meta_name
A.mcode
,
645 (Ast_c.parameterType
, Ast_c.il
) either list
) matcher
647 (A.meta_name
A.mcode
, Ast_c.parameterType
) matcher
649 (A.meta_name
A.mcode
, Ast_c.initialiser
) matcher
651 (A.meta_name
A.mcode
, (Ast_c.initialiser
, Ast_c.il
) either list
) matcher
653 (A.meta_name
A.mcode
, Ast_c.declaration
) matcher
655 (A.meta_name
A.mcode
, Ast_c.field
) matcher
657 (A.meta_name
A.mcode
, Control_flow_c.node
) matcher
659 val distrf_define_params
:
660 (A.meta_name
A.mcode
, (string Ast_c.wrap
, Ast_c.il
) either list
) matcher
662 val distrf_enum_fields
:
663 (A.meta_name
A.mcode
, (B.oneEnumType
, B.il
) either list
) matcher
665 val distrf_struct_fields
:
666 (A.meta_name
A.mcode
, B.field list
) matcher
669 (A.meta_name
A.mcode
, (B.constant
, string) either
B.wrap
) matcher
672 (A.expression
, B.expression
) matcher
-> (A.expression
, F.node
) matcher
676 (A.expression
, B.expression
) matcher
->
677 (A.expression
, B.expression
) matcher
680 (A.fullType
, B.fullType
) matcher
-> (A.fullType
, F.node
) matcher
683 (A.initialiser
, B.initialiser
) matcher
-> (A.initialiser
, F.node
) matcher
686 A.keep_binding
-> A.inherited
->
687 A.meta_name
A.mcode
* Ast_c.metavar_binding_kind
*
688 (unit -> Common.filename
* string * Ast_c.posl
* Ast_c.posl
) ->
689 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
691 val check_idconstraint
:
692 ('a
-> 'b
-> bool) -> 'a
-> 'b
->
693 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
695 val check_constraints_ne
:
696 ('a
, 'b
) matcher
-> 'a list
-> 'b
->
697 (unit -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
699 val all_bound
: A.meta_name list
-> (tin
-> bool)
701 val optional_storage_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
702 val optional_qualifier_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
703 val value_format_flag
: (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
704 val optional_declarer_semicolon_flag
:
705 (bool -> tin
-> 'x tout
) -> (tin
-> 'x tout
)
709 (*****************************************************************************)
710 (* Functor code, "Cocci vs C" *)
711 (*****************************************************************************)
714 functor (X
: PARAM
) ->
717 type ('a
, 'b
) matcher
= 'a
-> 'b
-> X.tin
-> ('a
* 'b
) X.tout
720 let return = X.return
723 let (>||>) = X.(>||>)
724 let (>|+|>) = X.(>|+|>)
725 let (>&&>) = X.(>&&>)
727 let tokenf = X.tokenf
729 (* should be raise Impossible when called from transformation.ml *)
732 | PatternMode
-> fail
733 | TransformMode
-> raise
(Impossible
22)
736 let (option: ('a
,'b
) matcher
-> ('a
option,'b
option) matcher
)= fun f t1 t2
->
738 | (Some t1
, Some t2
) ->
739 f t1 t2
>>= (fun t1 t2
->
740 return (Some t1
, Some t2
)
742 | (None
, None
) -> return (None
, None
)
745 (* Dots are sometimes used as metavariables, since like metavariables they
746 can match other things. But they no longer have the same type. Perhaps these
747 functions could be avoided by introducing an appropriate level of polymorphism,
748 but I don't know how to declare polymorphism across functors *)
749 let dots2metavar (_
,info
,mcodekind,pos
) =
750 (("","..."),info
,mcodekind,pos
)
751 let metavar2dots (_
,info
,mcodekind,pos
) = ("...",info
,mcodekind,pos
)
752 let metavar2ndots (_
,info
,mcodekind,pos
) = ("<+...",info
,mcodekind,pos
)
754 let satisfies_regexpconstraint c id
: bool =
756 A.IdRegExp
(_
,recompiled
) -> Regexp.string_match recompiled id
757 | A.IdNotRegExp
(_
,recompiled
) -> not
(Regexp.string_match recompiled id
)
759 let satisfies_iconstraint c id
: bool =
762 let satisfies_econstraint c exp
: bool =
763 let warning s
= pr2_once
("WARNING: "^s
); false in
764 match Ast_c.unwrap_expr exp
with
765 Ast_c.Ident
(name
) ->
767 Ast_c.RegularName rname
->
768 satisfies_regexpconstraint c
(Ast_c.unwrap_st rname
)
769 | Ast_c.CppConcatenatedName _
->
771 "Unable to apply a constraint on a CppConcatenatedName identifier!"
772 | Ast_c.CppVariadicName _
->
774 "Unable to apply a constraint on a CppVariadicName identifier!"
775 | Ast_c.CppIdentBuilder _
->
777 "Unable to apply a constraint on a CppIdentBuilder identifier!")
778 | Ast_c.Constant cst
->
780 | Ast_c.String
(str
, _
) -> satisfies_regexpconstraint c str
781 | Ast_c.MultiString strlist
->
782 warning "Unable to apply a constraint on a multistring constant!"
783 | Ast_c.Char
(char
, _
) -> satisfies_regexpconstraint c char
784 | Ast_c.Int
(int , _
) -> satisfies_regexpconstraint c
int
785 | Ast_c.Float
(float, _
) -> satisfies_regexpconstraint c
float)
786 | _
-> warning "Unable to apply a constraint on an expression!"
789 (* ------------------------------------------------------------------------- *)
790 (* This has to be up here to allow adequate polymorphism *)
792 let list_matcher match_dots rebuild_dots match_comma rebuild_comma
793 match_metalist rebuild_metalist mktermval special_cases
794 element distrf get_iis lenfilter
= fun eas ebs
->
795 let rec loop = function
796 [], [] -> return ([], [])
797 | [], eb
::ebs
-> fail
799 X.all_bound
(A.get_inherited ea
) >&&>
801 (match match_dots ea
, ebs
with
802 Some
(mcode
, optexpr
), ys
->
803 (* todo: if optexpr, then a WHEN and so may have to filter yys *)
804 if optexpr
<> None
then failwith
"not handling when in a list";
806 (* '...' can take more or less the beginnings of the arguments *)
808 (* if eas is empty there is only one possible match.
809 the same if eas is just a comma *)
812 | [c
] when not
(ys
=[]) &&
813 (match match_comma c
with Some _
-> true | None
-> false) ->
814 let r = List.rev ys
in
815 [(List.rev
(List.tl
r),[List.hd
r])]
817 Common.zip
(Common.inits ys
) (Common.tails ys
) in
819 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
822 (* allow '...', and maybe its associated ',' to match nothing.
823 * for the associated ',' see below how we handle the EComma
828 if mcode_contain_plus (mcodekind mcode
)
831 "I have no token that I could accroche myself on"*)
832 else return (dots2metavar mcode
, [])
834 (* subtil: we dont want the '...' to match until the
835 * comma. cf -test pb_params_iso. We would get at
836 * "already tagged" error.
837 * this is because both f (... x, ...) and f (..., x, ...)
838 * would match a f(x,3) with our "optional-comma" strategy.
840 (match Common.last startxs
with
842 | Left _
-> distrf
(dots2metavar mcode
) startxs
))
844 >>= (fun mcode startxs
->
845 let mcode = metavar2dots mcode in
846 loop (eas
, endxs
) >>= (fun eas endxs
->
848 (rebuild_dots
(mcode, optexpr
) +> A.rewrap ea
) ::eas
,
856 (match match_comma ea
, ebs
with
857 | Some ia1
, Right ii
::ebs
->
859 (let ib1 = tuple_of_list1 ii
in
860 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
861 loop (eas
, ebs
) >>= (fun eas ebs
->
863 (rebuild_comma ia1
+> A.rewrap ea
)::eas
,
868 (* allow ',' to maching nothing. optional comma trick *)
870 (if mcode_contain_plus (mcodekind ia1
)
872 else loop (eas
, ebs
))
875 (match match_metalist ea
, ebs
with
876 Some
(ida
,leninfo
,keep
,inherited
,extra
), ys
->
878 Common.zip
(Common.inits ys
) (Common.tails ys
) in
880 (startendxs +> List.fold_left
(fun acc
(startxs
, endxs
) ->
885 if mcode_contain_plus (mcodekind ida
)
887 (* failwith "no token that I could accroche myself on" *)
890 (match Common.last startxs
with
897 let startxs'
= Ast_c.unsplit_comma
startxs in
898 let len = List.length
(lenfilter
startxs'
) in
901 | A.MetaListLen
(lenname
,lenkeep
,leninherited
) ->
902 let max_min _
= failwith
"no pos" in
903 X.envf lenkeep leninherited
904 (lenname
, Ast_c.MetaListlenVal
(len), max_min)
907 then (function f
-> f
())
908 else (function f
-> fail)
909 | A.AnyListLen
-> function f
-> f
())
912 Lib_parsing_c.lin_col_by_pos
(get_iis
startxs) in
915 extra
startxs'
max_min
916 (fun _
-> return ((),()))
917 | None
-> return ((),()))
920 X.envf keep inherited
921 (ida
, mktermval
startxs'
, max_min)
924 then return (ida
, [])
925 else distrf ida
(Ast_c.split_comma
startxs'
))
926 >>= (fun ida
startxs ->
927 loop (eas
, endxs
) >>= (fun eas endxs
->
930 (ida
,leninfo
,keep
,inherited
))
939 special_cases ea eas ebs
in
940 match try_matches with
945 element ea eb
>>= (fun ea eb
->
946 loop (eas
, ebs
) >>= (fun eas ebs
->
947 return (ea
::eas
, Left eb
::ebs
)))
948 | (Right y
)::ys
-> raise
(Impossible
23)
952 (*---------------------------------------------------------------------------*)
964 (*---------------------------------------------------------------------------*)
965 let rec (expression
: (A.expression
, Ast_c.expression
) matcher
) =
967 if A.get_test_exp ea
&& not
(Ast_c.is_test eb
) then fail
969 X.all_bound
(A.get_inherited ea
) >&&>
970 let wa x
= A.rewrap ea x
in
971 match A.unwrap ea
, eb
with
973 (* general case: a MetaExpr can match everything *)
974 | A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
),
975 (((expr
, opttypb
), ii
) as expb
) ->
977 (* old: before have a MetaConst. Now we factorize and use 'form' to
978 * differentiate between different cases *)
979 let rec matches_id = function
980 B.Ident
(name
) -> true
981 | B.Cast
(ty
,e
) -> matches_id (B.unwrap_expr e
)
984 match (form
,expr
) with
987 let rec matches = function
988 B.Constant
(c
) -> true
989 | B.Ident
(nameidb
) ->
990 let s = Ast_c.str_of_name nameidb
in
991 if s =~
"^[A-Z_][A-Z_0-9]*$"
993 pr2_once
("warning: " ^
s ^
" treated as a constant");
997 | B.Cast
(ty
,e
) -> matches (B.unwrap_expr e
)
998 | B.Unary
(e
,B.UnMinus
) -> matches (B.unwrap_expr e
)
999 | B.SizeOfExpr
(exp
) -> true
1000 | B.SizeOfType
(ty
) -> true
1005 (match !opttypb
with
1006 (Some
(_
,Ast_c.LocalVar _
),_
) -> true
1008 | (A.ID
,e
) -> matches_id e
in
1012 (let (opttypb
,_testb
) = !opttypb
in
1013 match opttypa
, opttypb
with
1014 | None
, _
-> return ((),())
1016 pr2_once
("Missing type information. Certainly a pb in " ^
1017 "annotate_typer.ml");
1020 | Some tas
, Some tb
->
1021 tas
+> List.fold_left
(fun acc ta
->
1022 acc
>|+|> compatible_type ta tb
) fail
1025 let meta_expr_val l x
= Ast_c.MetaExprVal
(x
,l
) in
1026 match constraints
with
1027 Ast_cocci.NoConstraint
-> return (meta_expr_val [],())
1028 | Ast_cocci.NotIdCstrt cstrt
->
1029 X.check_idconstraint
satisfies_econstraint cstrt eb
1030 (fun () -> return (meta_expr_val [],()))
1031 | Ast_cocci.NotExpCstrt cstrts
->
1032 X.check_constraints_ne expression cstrts eb
1033 (fun () -> return (meta_expr_val [],()))
1034 | Ast_cocci.SubExpCstrt cstrts
->
1035 return (meta_expr_val cstrts
,()))
1039 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_expr expb
) in
1040 X.envf keep inherited
(ida
, wrapper expb
, max_min)
1042 X.distrf_e ida expb
>>=
1045 A.MetaExpr
(ida
,constraints
,keep
,opttypa
,form
,inherited
)+>
1053 * | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
1054 * D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
1056 * but bug! because if have not tagged SP, then transform without doing
1057 * any checks. Hopefully now have tagged SP technique.
1060 | A.AsExpr
(exp
,asexp
), expb
->
1061 expression exp expb
>>= (fun exp expb
->
1062 expression asexp expb
>>= (fun asexp expb
->
1064 ((A.AsExpr
(exp
,asexp
)) +> wa,
1068 * | A.Edots _, _ -> raise Impossible.
1070 * In fact now can also have the Edots inside normal expression, not
1071 * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
1073 | A.Edots
(mcode, None
), expb
->
1074 X.distrf_e
(dots2metavar mcode) expb
>>= (fun mcode expb
->
1076 A.Edots
(metavar2dots mcode, None
) +> A.rewrap ea
,
1081 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
1084 | A.Ident ida
, ((B.Ident
(nameidb
), typ),noii
) ->
1086 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1088 ((A.Ident ida
)) +> wa,
1089 ((B.Ident
(nameidb
), typ),Ast_c.noii
)
1095 | A.MetaErr _
, _
-> failwith
"not handling MetaErr"
1097 (* todo?: handle some isomorphisms in int/float ? can have different
1098 * format : 1l can match a 1.
1100 * todo: normally string can contain some metavar too, so should
1101 * recurse on the string
1103 | A.Constant
(ia1
), ((B.Constant
(ib
) , typ),ii
) ->
1104 (* for everything except the String case where can have multi elems *)
1106 let ib1 = tuple_of_list1 ii
in
1107 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1109 ((A.Constant ia1
)) +> wa,
1110 ((B.Constant
(ib
), typ),[ib1])
1113 (match term ia1
, ib
with
1114 | A.Int x
, B.Int
(y
,_
) ->
1115 X.value_format_flag
(fun use_value_equivalence
->
1116 if use_value_equivalence
1126 | A.Char x
, B.Char
(y
,_
) when x
=$
= y
(* todo: use kind ? *)
1128 | A.Float x
, B.Float
(y
,_
) when x
=$
= y
(* todo: use floatType ? *)
1131 | A.String sa
, B.String
(sb
,_kind
) when sa
=$
= sb
->
1134 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1136 ((A.Constant ia1
)) +> wa,
1137 ((B.Constant
(ib
), typ),[ib1])
1139 | _
-> fail (* multi string, not handled *)
1142 | _
, B.MultiString _
-> (* todo cocci? *) fail
1143 | _
, (B.String _
| B.Float _
| B.Char _
| B.Int _
) -> fail
1147 | A.FunCall
(ea
, ia1
, eas
, ia2
), ((B.FunCall
(eb
, ebs
), typ),ii
) ->
1148 (* todo: do special case to allow IdMetaFunc, cos doing the
1149 * recursive call will be too late, match_ident will not have the
1150 * info whether it was a function. todo: but how detect when do
1151 * x.field = f; how know that f is a Func ? By having computed
1152 * some information before the matching!
1154 * Allow match with FunCall containing types. Now ast_cocci allow
1155 * type in parameter, and morover ast_cocci allow f(...) and those
1156 * ... could match type.
1158 let (ib1, ib2
) = tuple_of_list2 ii
in
1159 expression ea eb
>>= (fun ea eb
->
1160 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1161 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1162 arguments
(seqstyle eas
) (A.undots eas
) ebs
>>= (fun easundots ebs
->
1163 let eas = redots
eas easundots
in
1165 ((A.FunCall
(ea
, ia1
, eas, ia2
)) +> wa,
1166 ((B.FunCall
(eb
, ebs
),typ), [ib1;ib2
])
1169 | A.Assignment
(ea1
, opa
, ea2
, simple
),
1170 ((B.Assignment
(eb1
, opb
, eb2
), typ),ii
) ->
1171 let (opbi
) = tuple_of_list1 ii
in
1172 if equal_assignOp (term opa
) opb
1174 expression ea1 eb1
>>= (fun ea1 eb1
->
1175 expression ea2 eb2
>>= (fun ea2 eb2
->
1176 tokenf opa opbi
>>= (fun opa opbi
->
1178 (A.Assignment
(ea1
, opa
, ea2
, simple
)) +> wa,
1179 ((B.Assignment
(eb1
, opb
, eb2
), typ), [opbi
])
1183 | A.Sequence
(ea1
, opa
, ea2
),
1184 ((B.Sequence
(eb1
, eb2
), typ),ii
) ->
1185 let (opbi
) = tuple_of_list1 ii
in
1186 expression ea1 eb1
>>= (fun ea1 eb1
->
1187 expression ea2 eb2
>>= (fun ea2 eb2
->
1188 tokenf opa opbi
>>= (fun opa opbi
->
1190 (A.Sequence
(ea1
, opa
, ea2
)) +> wa,
1191 ((B.Sequence
(eb1
, eb2
), typ), [opbi
])
1194 | A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
),((B.CondExpr
(eb1
,eb2opt
,eb3
),typ),ii
) ->
1195 let (ib1, ib2
) = tuple_of_list2 ii
in
1196 expression ea1 eb1
>>= (fun ea1 eb1
->
1197 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
1198 expression ea3 eb3
>>= (fun ea3 eb3
->
1199 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1200 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1202 ((A.CondExpr
(ea1
,ia1
,ea2opt
,ia2
,ea3
))) +> wa,
1203 ((B.CondExpr
(eb1
, eb2opt
, eb3
),typ), [ib1;ib2
])
1206 (* todo?: handle some isomorphisms here ? *)
1207 | A.Postfix
(ea
, opa
), ((B.Postfix
(eb
, opb
), typ),ii
) ->
1208 let opbi = tuple_of_list1 ii
in
1209 if equal_fixOp (term opa
) opb
1211 expression ea eb
>>= (fun ea eb
->
1212 tokenf opa
opbi >>= (fun opa
opbi ->
1214 ((A.Postfix
(ea
, opa
))) +> wa,
1215 ((B.Postfix
(eb
, opb
), typ),[opbi])
1220 | A.Infix
(ea
, opa
), ((B.Infix
(eb
, opb
), typ),ii
) ->
1221 let opbi = tuple_of_list1 ii
in
1222 if equal_fixOp (term opa
) opb
1224 expression ea eb
>>= (fun ea eb
->
1225 tokenf opa
opbi >>= (fun opa
opbi ->
1227 ((A.Infix
(ea
, opa
))) +> wa,
1228 ((B.Infix
(eb
, opb
), typ),[opbi])
1232 | A.Unary
(ea
, opa
), ((B.Unary
(eb
, opb
), typ),ii
) ->
1233 let opbi = tuple_of_list1 ii
in
1234 if equal_unaryOp (term opa
) opb
1236 expression ea eb
>>= (fun ea eb
->
1237 tokenf opa
opbi >>= (fun opa
opbi ->
1239 ((A.Unary
(ea
, opa
))) +> wa,
1240 ((B.Unary
(eb
, opb
), typ),[opbi])
1244 | A.Binary
(ea1
, opa
, ea2
), ((B.Binary
(eb1
, opb
, eb2
), typ),ii
) ->
1245 let opbi = tuple_of_list1 ii
in
1246 if equal_binaryOp (term opa
) opb
1248 expression ea1 eb1
>>= (fun ea1 eb1
->
1249 expression ea2 eb2
>>= (fun ea2 eb2
->
1250 tokenf opa
opbi >>= (fun opa
opbi ->
1252 ((A.Binary
(ea1
, opa
, ea2
))) +> wa,
1253 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1257 | A.Nested
(ea1
, opa
, ea2
), eb
->
1259 expression ea1 eb
>|+|>
1261 ((B.Binary
(eb1
, opb
, eb2
), typ),ii
)
1262 when equal_binaryOp (term opa
) opb
->
1263 let opbi = tuple_of_list1 ii
in
1265 (expression ea1 eb1
>>= (fun ea1 eb1
->
1266 expression ea2 eb2
>>= (fun ea2 eb2
->
1267 tokenf opa
opbi >>= (fun opa
opbi ->
1269 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1270 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1273 (expression ea2 eb1
>>= (fun ea2 eb1
->
1274 expression ea1 eb2
>>= (fun ea1 eb2
->
1275 tokenf opa
opbi >>= (fun opa
opbi ->
1277 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1278 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1281 (expression ea2 eb2
>>= (fun ea2 eb2
->
1282 tokenf opa
opbi >>= (fun opa
opbi ->
1283 (* be last, to be sure the rest is marked *)
1284 loop eb1
>>= (fun ea1 eb1
->
1286 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1287 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1290 (expression ea2 eb1
>>= (fun ea2 eb1
->
1291 tokenf opa
opbi >>= (fun opa
opbi ->
1292 (* be last, to be sure the rest is marked *)
1293 loop eb2
>>= (fun ea1 eb2
->
1295 ((A.Nested
(ea1
, opa
, ea2
))) +> wa,
1296 ((B.Binary
(eb1
, opb
, eb2
), typ),[opbi]
1298 left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
1302 (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
1303 | A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
),((B.ArrayAccess
(eb1
, eb2
), typ),ii
) ->
1304 let (ib1, ib2
) = tuple_of_list2 ii
in
1305 expression ea1 eb1
>>= (fun ea1 eb1
->
1306 expression ea2 eb2
>>= (fun ea2 eb2
->
1307 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1308 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1310 ((A.ArrayAccess
(ea1
, ia1
, ea2
, ia2
))) +> wa,
1311 ((B.ArrayAccess
(eb1
, eb2
),typ), [ib1;ib2
])
1314 (* todo?: handle some isomorphisms here ? *)
1315 | A.RecordAccess
(ea
, ia1
, ida
), ((B.RecordAccess
(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.RecordAccess
(ea
, ia1
, ida
))) +> wa,
1322 ((B.RecordAccess
(eb
, idb
), typ), [ib1])
1327 | A.RecordPtAccess
(ea
,ia1
,ida
),((B.RecordPtAccess
(eb
, idb
), typ), ii
) ->
1328 let (ib1) = tuple_of_list1 ii
in
1329 ident_cpp DontKnow ida idb
>>= (fun ida idb
->
1330 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1331 expression ea eb
>>= (fun ea eb
->
1333 ((A.RecordPtAccess
(ea
, ia1
, ida
))) +> wa,
1334 ((B.RecordPtAccess
(eb
, idb
), typ), [ib1])
1338 (* todo?: handle some isomorphisms here ?
1339 * todo?: do some iso-by-absence on cast ?
1340 * by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
1343 | A.Cast
(ia1
, typa
, ia2
, ea
), ((B.Cast
(typb
, eb
), typ),ii
) ->
1344 let (ib1, ib2
) = tuple_of_list2 ii
in
1345 fullType typa typb
>>= (fun typa typb
->
1346 expression ea eb
>>= (fun ea eb
->
1347 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1348 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1350 ((A.Cast
(ia1
, typa
, ia2
, ea
))) +> wa,
1351 ((B.Cast
(typb
, eb
),typ),[ib1;ib2
])
1354 | A.SizeOfExpr
(ia1
, ea
), ((B.SizeOfExpr
(eb
), typ),ii
) ->
1355 let ib1 = tuple_of_list1 ii
in
1356 expression ea eb
>>= (fun ea eb
->
1357 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1359 ((A.SizeOfExpr
(ia1
, ea
))) +> wa,
1360 ((B.SizeOfExpr
(eb
), typ),[ib1])
1363 | A.SizeOfType
(ia1
, ia2
, typa
, ia3
), ((B.SizeOfType typb
, typ),ii
) ->
1364 let (ib1,ib2
,ib3
) = tuple_of_list3 ii
in
1365 fullType typa typb
>>= (fun typa typb
->
1366 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1367 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1368 tokenf ia3 ib3
>>= (fun ia3 ib3
->
1370 ((A.SizeOfType
(ia1
, ia2
, typa
, ia3
))) +> wa,
1371 ((B.SizeOfType
(typb
),typ),[ib1;ib2
;ib3
])
1375 (* todo? iso ? allow all the combinations ? *)
1376 | A.Paren
(ia1
, ea
, ia2
), ((B.ParenExpr
(eb
), typ),ii
) ->
1377 let (ib1, ib2
) = tuple_of_list2 ii
in
1378 expression ea eb
>>= (fun ea eb
->
1379 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1380 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1382 ((A.Paren
(ia1
, ea
, ia2
))) +> wa,
1383 ((B.ParenExpr
(eb
), typ), [ib1;ib2
])
1386 | A.NestExpr
(starter
,exps
,ender
,None
,true), eb
->
1387 (match A.unwrap exps
with
1389 (* if minus and trafo do nothing *)
1390 X.cocciExpExp
(A.get_mcodekind starter
)
1391 expression exp eb
>>= (fun exp eb
->
1392 (* minus and trafo will do something here *)
1393 X.distrf_e
(dots2metavar starter
) eb
>>= (fun mcode eb
->
1396 (metavar2ndots mcode,
1397 A.rewrap exps
(A.DOTS
[exp
]),ender
,None
,true)) +> wa,
1403 "for nestexpr, only handling the case with dots and only one exp")
1405 | A.NestExpr _
, _
->
1406 failwith
"only handling multi and no when code in a nest expr"
1408 (* only in arg lists or in define body *)
1409 | A.TypeExp _
, _
-> fail
1411 | A.Constructor
(ia1
, typa
, ia2
, ia
), ((B.Constructor
(typb
, ib
), typ),ii
) ->
1412 let (ib1, ib2
) = tuple_of_list2 ii
in
1413 fullType typa typb
>>= (fun typa typb
->
1414 initialiser ia ib
>>= (fun ia ib
->
1415 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
1416 tokenf ia2 ib2
>>= (fun ia2 ib2
->
1418 ((A.Constructor
(ia1
, typa
, ia2
, ia
))) +> wa,
1419 ((B.Constructor
(typb
, ib
),typ),[ib1;ib2
])
1422 (* only in arg lists *)
1423 | A.MetaExprList _
, _
1428 raise
(Impossible
24)
1430 | A.DisjExpr
eas, eb
->
1431 eas +> List.fold_left
(fun acc ea
-> acc
>|+|> (expression ea eb
)) fail
1433 | A.UniqueExp _
,_
| A.OptExp _
,_
->
1434 failwith
"not handling Opt/Unique/Multi on expr"
1436 (* Because of Exp cant put a raise Impossible; have to put a fail *)
1438 (* have not a counter part in coccinelle, for the moment *)
1439 | _
, ((B.Sequence _
,_
),_
)
1440 | _
, ((B.StatementExpr _
,_
),_
)
1441 | _
, ((B.New _
,_
),_
)
1442 | _
, ((B.Delete _
,_
),_
)
1447 (((B.Cast
(_
, _
)|B.ParenExpr _
|B.SizeOfType _
|B.SizeOfExpr _
|
1448 B.Constructor
(_
, _
)|
1449 B.RecordPtAccess
(_
, _
)|
1450 B.RecordAccess
(_
, _
)|B.ArrayAccess
(_
, _
)|
1451 B.Binary
(_
, _
, _
)|B.Unary
(_
, _
)|
1452 B.Infix
(_
, _
)|B.Postfix
(_
, _
)|
1453 B.Assignment
(_
, _
, _
)|B.CondExpr
(_
, _
, _
)|
1454 B.FunCall
(_
, _
)|B.Constant _
|B.Ident _
),
1462 (* ------------------------------------------------------------------------- *)
1463 and (ident_cpp
: info_ident
-> (A.ident, B.name
) matcher
) =
1464 fun infoidb ida idb
->
1466 | B.RegularName
(s, iis) ->
1467 let iis = tuple_of_list1
iis in
1468 ident infoidb ida
(s, iis) >>= (fun ida
(s,iis) ->
1471 (B.RegularName
(s, [iis]))
1473 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
1475 (* This should be moved to the Id case of ident. Metavariables
1476 should be allowed to be bound to such variables. But doing so
1477 would require implementing an appropriate distr function *)
1480 and (ident: info_ident
-> (A.ident, string * Ast_c.info
) matcher
) =
1481 fun infoidb ida
((idb
, iib
) as ib
) -> (* (idb, iib) as ib *)
1482 let check_constraints constraints idb
=
1483 let meta_id_val l x
= Ast_c.MetaIdVal
(x
,l
) in
1484 match constraints
with
1485 A.IdNoConstraint
-> return (meta_id_val [],())
1486 | A.IdNegIdSet
(str
,meta
) ->
1487 X.check_idconstraint
satisfies_iconstraint str idb
1488 (fun () -> return (meta_id_val meta
,()))
1489 | A.IdRegExpConstraint re
->
1490 X.check_idconstraint
satisfies_regexpconstraint re idb
1491 (fun () -> return (meta_id_val [],())) in
1492 X.all_bound
(A.get_inherited ida
) >&&>
1493 match A.unwrap ida
with
1495 if (term sa
) =$
= idb
then
1496 tokenf sa iib
>>= (fun sa iib
->
1498 ((A.Id sa
)) +> A.rewrap ida
,
1503 | A.MetaId
(mida
,constraints
,keep
,inherited
) ->
1504 check_constraints constraints idb
>>=
1506 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1507 (* use drop_pos for ids so that the pos is not added a second time in
1508 the call to tokenf *)
1509 X.envf keep inherited
(A.drop_pos mida
, wrapper idb
, max_min)
1511 tokenf mida iib
>>= (fun mida iib
->
1513 ((A.MetaId
(mida
, constraints
, keep
, inherited
)) +> A.rewrap ida
,
1518 | A.MetaFunc
(mida
,constraints
,keep
,inherited
) ->
1520 check_constraints constraints idb
>>=
1522 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1523 X.envf keep inherited
(A.drop_pos mida
,Ast_c.MetaFuncVal idb
,max_min)
1525 tokenf mida iib
>>= (fun mida iib
->
1527 ((A.MetaFunc
(mida
,constraints
,keep
,inherited
)))+>A.rewrap ida
,
1532 | LocalFunction
| Function
-> is_function()
1534 failwith
"MetaFunc, need more semantic info about id"
1535 (* the following implementation could possibly be useful, if one
1536 follows the convention that a macro is always in capital letters
1537 and that a macro is not a function.
1538 (if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
1541 | A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
) ->
1544 check_constraints constraints idb
>>=
1546 let max_min _
= Lib_parsing_c.lin_col_by_pos
[iib
] in
1547 X.envf keep inherited
1548 (A.drop_pos mida
,Ast_c.MetaLocalFuncVal idb
, max_min)
1550 tokenf mida iib
>>= (fun mida iib
->
1552 ((A.MetaLocalFunc
(mida
,constraints
,keep
,inherited
)))
1558 | DontKnow
-> failwith
"MetaLocalFunc, need more semantic info about id"
1561 | A.AsIdent
(id
,asid
) ->
1562 ident infoidb id ib
>>= (fun id ib
->
1563 ident infoidb asid ib
>>= (fun asid ib
->
1565 ((A.AsIdent
(id
,asid
)) +> A.rewrap ida
,
1568 (* not clear why disj things are needed, after disjdistr? *)
1570 ias
+> List.fold_left
(fun acc ia
-> acc
>|+|> (ident infoidb ia ib
)) fail
1572 | A.OptIdent _
| A.UniqueIdent _
->
1573 failwith
"not handling Opt/Unique for ident"
1575 (* ------------------------------------------------------------------------- *)
1576 and (arguments
: sequence
->
1577 (A.expression list
, Ast_c.argument
Ast_c.wrap2 list
) matcher
) =
1578 fun seqstyle eas ebs
->
1580 | Unordered
-> failwith
"not handling ooo"
1582 arguments_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1583 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1585 (* because '...' can match nothing, need to take care when have
1586 * ', ...' or '...,' as in f(..., X, Y, ...). It must match
1587 * f(1,2) for instance.
1588 * So I have added special cases such as (if startxs = []) and code
1589 * in the Ecomma matching rule.
1591 * old: Must do some try, for instance when f(...,X,Y,...) have to
1592 * test the transfo for all the combinations and if multiple transfo
1593 * possible ? pb ? => the type is to return a expression option ? use
1594 * some combinators to help ?
1595 * update: with the tag-SP approach, no more a problem.
1598 and arguments_bis
= fun eas ebs
->
1600 match A.unwrap ea
with
1601 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
1603 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
1604 let match_comma ea
=
1605 match A.unwrap ea
with
1606 A.EComma ia1
-> Some ia1
1608 let build_comma ia1
= A.EComma ia1
in
1609 let match_metalist ea
=
1610 match A.unwrap ea
with
1611 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) ->
1612 Some
(ida
,leninfo
,keep
,inherited
,None
)
1614 let build_metalist _
(ida
,leninfo
,keep
,inherited
) =
1615 A.MetaExprList
(ida
,leninfo
,keep
,inherited
) in
1616 let mktermval v
= Ast_c.MetaExprListVal v
in
1617 let special_cases ea
eas ebs
= None
in
1618 list_matcher match_dots build_dots match_comma build_comma
1619 match_metalist build_metalist mktermval
1620 special_cases argument
X.distrf_args
1621 Lib_parsing_c.ii_of_args
(function x
-> x
) eas ebs
1623 and argument arga argb
=
1624 X.all_bound
(A.get_inherited arga
) >&&>
1625 match A.unwrap arga
, argb
with
1627 Right
(B.ArgType
{B.p_register
=b
,iib
; p_namei
=sopt
;p_type
=tyb
}) ->
1628 if b
|| sopt
<> None
1630 (* failwith "the argument have a storage and ast_cocci does not have"*)
1633 (* b = false and sopt = None *)
1634 fullType tya tyb
>>= (fun tya tyb
->
1636 (A.TypeExp tya
) +> A.rewrap arga
,
1637 (Right
(B.ArgType
{B.p_register
=(b
,iib
);
1642 | A.TypeExp tya
, _
-> fail
1643 | _
, Right
(B.ArgType _
) -> fail
1645 expression arga argb
>>= (fun arga argb
->
1646 return (arga
, Left argb
)
1648 | _
, Right
(B.ArgAction y
) -> fail
1651 (* ------------------------------------------------------------------------- *)
1652 (* todo? facto code with argument ? *)
1653 and (parameters
: sequence
->
1654 (A.parameterTypeDef list
, Ast_c.parameterType
Ast_c.wrap2 list
)
1656 fun seqstyle eas ebs
->
1658 | Unordered
-> failwith
"not handling ooo"
1660 parameters_bis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
1661 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
1664 and parameters_bis
eas ebs
=
1666 match A.unwrap ea
with
1667 A.Pdots
(mcode) -> Some
(mcode, None
)
1669 let build_dots (mcode, _optexpr
) = A.Pdots
(mcode) in
1670 let match_comma ea
=
1671 match A.unwrap ea
with
1672 A.PComma ia1
-> Some ia1
1674 let build_comma ia1
= A.PComma ia1
in
1675 let match_metalist ea
=
1676 let rec loop acc p
=
1677 match A.unwrap p
with
1678 A.AsParam
(p
,e
) -> loop (e
:: acc
) p
1679 | A.MetaParamList
(ida
,leninfo
,keep
,inherited
) ->
1680 Some
((ida
,leninfo
,keep
,inherited
),acc
)
1682 match loop [] ea
with
1683 Some
((ida
,leninfo
,keep
,inherited
),ids
) ->
1685 [] -> Some
(ida
,leninfo
,keep
,inherited
,None
)
1687 let extra vl
max_min k
=
1689 Ast_c.MetaExprListVal
1692 match v
.Ast_c.p_namei
with
1694 (Left
(Ast_c.mk_e
(B.Ident name
) Ast_c.noii
),i
)
1695 | None
-> failwith
"no name in parameter list")
1697 let rec loop = function
1700 (match A.unwrap x
with
1701 A.MetaExprList
(ida
,A.AnyListLen
,keep
,inherited
) ->
1702 X.envf keep inherited
1705 | A.MetaExprList _
->
1706 failwith
"length not supported"
1707 | _
-> failwith
"unexpected expression") in
1709 Some
(ida
,leninfo
,keep
,inherited
,Some
extra))
1711 let rec build_metalist ea
(ida
,leninfo
,keep
,inherited
) =
1712 match A.unwrap ea
with
1713 A.MetaParamList _
->
1714 A.MetaParamList
(ida
,leninfo
,keep
,inherited
)
1716 A.AsParam
(A.rewrap p
(build_metalist p
(ida
,leninfo
,keep
,inherited
)),
1718 | _
-> failwith
"not possible" in
1719 let mktermval v
= Ast_c.MetaParamListVal v
in
1720 let special_cases ea
eas ebs
=
1721 (* a case where one smpl parameter matches a list of C parameters *)
1722 match A.unwrap ea
,ebs
with
1723 A.VoidParam ta
, ys
->
1725 (match eas, ebs
with
1727 let {B.p_register
=(hasreg
,iihasreg
);
1729 p_type
=tb
; } = eb
in
1731 if idbopt
=*= None
&& not hasreg
1734 | (qub
, (B.BaseType
B.Void
,_
)) ->
1735 fullType ta tb
>>= (fun ta tb
->
1737 [(A.VoidParam ta
) +> A.rewrap ea
],
1738 [Left
{B.p_register
=(hasreg
, iihasreg
);
1746 list_matcher match_dots build_dots match_comma build_comma
1747 match_metalist build_metalist mktermval
1748 special_cases parameter
X.distrf_params
1749 Lib_parsing_c.ii_of_params
(function x
-> x
) eas ebs
1752 let split_register_param = fun (hasreg, idb, ii_b_s) ->
1753 match hasreg, idb, ii_b_s with
1754 | false, Some s, [i1] -> Left (s, [], i1)
1755 | true, Some s, [i1;i2] -> Left (s, [i1], i2)
1756 | _, None, ii -> Right ii
1757 | _ -> raise Impossible
1761 and parameter
= fun parama paramb
->
1762 match A.unwrap parama
, paramb
with
1763 A.MetaParam
(ida
,keep
,inherited
), eb
->
1764 (* todo: use quaopt, hasreg ? *)
1766 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_param eb
) in
1767 X.envf keep inherited
(ida
,Ast_c.MetaParamVal eb
,max_min) (fun () ->
1768 X.distrf_param ida eb
1769 ) >>= (fun ida eb
->
1770 return (A.MetaParam
(ida
,keep
,inherited
)+> A.rewrap parama
,eb
))
1771 | A.Param
(typa
, idaopt
), eb
->
1772 let {B.p_register
= (hasreg
,iihasreg
);
1773 p_namei
= nameidbopt
;
1774 p_type
= typb
;} = paramb
in
1776 fullType typa typb
>>= (fun typa typb
->
1777 match idaopt
, nameidbopt
with
1778 | Some ida
, Some nameidb
->
1779 (* todo: if minus on ida, should also minus the iihasreg ? *)
1780 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
1782 A.Param
(typa
, Some ida
)+> A.rewrap parama
,
1783 {B.p_register
= (hasreg
, iihasreg
);
1784 p_namei
= Some
(nameidb
);
1790 A.Param
(typa
, None
)+> A.rewrap parama
,
1791 {B.p_register
=(hasreg
,iihasreg
);
1795 (* why handle this case ? because of transform_proto ? we may not
1796 * have an ident in the proto.
1797 * If have some plus on ida ? do nothing about ida ?
1799 (* not anymore !!! now that julia is handling the proto.
1800 | _, Right iihasreg ->
1803 ((hasreg, None, typb), iihasreg)
1807 | Some _
, None
-> fail
1808 | None
, Some _
-> fail)
1809 | (A.OptParam _
| A.UniqueParam _
), _
->
1810 failwith
"not handling Opt/Unique for Param"
1811 | A.Pcircles
(_
), ys
-> raise
(Impossible
25) (* in Ordered mode *)
1814 (* ------------------------------------------------------------------------- *)
1815 and (declaration
: (A.mcodekind * bool * A.declaration
,B.declaration
) matcher
) =
1816 fun (mckstart
, allminus
, decla
) declb
->
1817 X.all_bound
(A.get_inherited decla
) >&&>
1818 match A.unwrap decla
, declb
with
1820 (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
1821 * de toutes les declarations qui sont au debut d'un fonction et
1822 * commencer le reste du match au premier statement. Alors, ca matche
1823 * n'importe quelle declaration. On n'a pas besoin d'ajouter
1824 * quoi que ce soit dans l'environnement. C'est une sorte de DDots.
1826 * When the SP want to remove the whole function, the minus is not
1827 * on the MetaDecl but on the MetaRuleElem. So there should
1828 * be no transform of MetaDecl, just matching are allowed.
1831 | A.MetaDecl
(ida
,keep
,inherited
), _
->
1833 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_decl declb
) in
1834 X.envf keep inherited
(ida
, Ast_c.MetaDeclVal declb
, max_min) (fun () ->
1835 X.distrf_decl ida declb
1836 ) >>= (fun ida declb
->
1837 return ((mckstart
, allminus
,
1838 (A.MetaDecl
(ida
, keep
, inherited
))+> A.rewrap decla
),
1841 | A.AsDecl
(dec
,asdec
), decb
->
1842 declaration
(mckstart
, allminus
, dec
) decb
>>=
1843 (fun (mckstart
, allminus
, dec
) decb
->
1844 let asmckstart = A.CONTEXT
(A.NoPos
,A.NOTHING
) in
1845 declaration
(asmckstart,false,asdec
) decb
>>= (fun (_
,_
,asdec
) decb
->
1847 ((mckstart
, allminus
,
1848 (A.AsDecl
(dec
,asdec
)) +> A.rewrap decla
),
1851 | _
, (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
)) ->
1852 onedecl allminus decla
(var
,iiptvirgb
,iisto
) >>=
1853 (fun decla
(var
,iiptvirgb
,iisto
)->
1854 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1856 (mckstart
, allminus
, decla
),
1857 (B.DeclList
([var
], iiptvirgb
::iifakestart
::iisto
))
1860 | _
, (B.DeclList
(xs
, (iiptvirgb
::iifakestart
::iisto
))) ->
1862 let rec loop n
= function
1864 | x
::xs
-> (n
,x
)::(loop (n
+1) xs
) in
1866 let rec repln n
vl cur
= function
1869 if n
= cur
then vl :: xs
else x
:: (repln n
vl (cur
+1) xs
) in
1870 if !Flag.sgrep_mode2
(*X.mode =*= PatternMode *) || A.get_safe_decl decla
1872 (indexify xs
) +> List.fold_left
(fun acc
(n
,var
) ->
1873 (* consider all possible matches *)
1874 acc
>||> (function tin
-> (
1875 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1876 onedecl allminus decla
(var
, iiptvirgb
, iisto
) >>=
1877 (fun decla
(var
, iiptvirgb
, iisto
) ->
1879 (mckstart
, allminus
, decla
),
1880 (* adjust the variable that was chosen *)
1881 (B.DeclList
(repln n var
0 xs
,
1882 iiptvirgb
::iifakestart
::iisto
))
1887 let firstii = iiptvirgb
in
1889 (Printf.sprintf
"%s: %d: %s"
1890 (Ast_c.file_of_info
firstii) (Ast_c.line_of_info
firstii)
1891 "More than one variable in the declaration, and so it cannot be transformed. Check that there is no transformation on the type or the ;");
1895 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
,true),ii
) ->
1896 let (iisb
, lpb
, rpb
, iiendb
, iifakestart
, iistob
) =
1898 | iisb
::lpb
::rpb
::iiendb
::iifakestart
::iisto
->
1899 (iisb
,lpb
,rpb
,iiendb
, iifakestart
,iisto
)
1900 | _
-> raise
(Impossible
26)
1903 then minusize_list iistob
1904 else return ((), iistob
)
1905 ) >>= (fun () iistob
->
1907 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1908 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1909 tokenf lpa lpb
>>= (fun lpa lpb
->
1910 tokenf rpa rpb
>>= (fun rpa rpb
->
1911 tokenf enda iiendb
>>= (fun enda iiendb
->
1912 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1913 let eas = redots
eas easundots
in
1916 (mckstart
, allminus
,
1917 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1918 (B.MacroDecl
((sb
,ebs
,true),
1919 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1922 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
), B.MacroDecl
((sb
,ebs
,false),ii
) ->
1923 X.optional_declarer_semicolon_flag
(fun optional_declarer_semicolon
->
1924 match mcodekind enda
, optional_declarer_semicolon
with
1925 A.CONTEXT
(_
,A.NOTHING
), true ->
1926 let (iisb
, lpb
, rpb
, iifakestart
, iistob
) =
1928 | iisb
::lpb
::rpb
::iifakestart
::iisto
->
1929 (iisb
,lpb
,rpb
,iifakestart
,iisto
)
1930 | _
-> raise
(Impossible
27)) in
1932 then minusize_list iistob
1933 else return ((), iistob
)) >>=
1936 X.tokenf_mck mckstart iifakestart
>>=
1937 (fun mckstart iifakestart
->
1938 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1939 tokenf lpa lpb
>>= (fun lpa lpb
->
1940 tokenf rpa rpb
>>= (fun rpa rpb
->
1941 arguments
(seqstyle eas) (A.undots
eas) ebs
>>=
1942 (fun easundots ebs
->
1943 let eas = redots
eas easundots
in
1946 (mckstart
, allminus
,
1947 (A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
)) +> A.rewrap decla
),
1948 (B.MacroDecl
((sb
,ebs
,false),
1949 [iisb
;lpb
;rpb
;iifakestart
] ++ iistob
))
1953 | A.MacroDeclInit
(sa
,lpa
,eas,rpa
,weqa
,inia
,enda
),
1954 B.MacroDeclInit
((sb
,ebs
,inib
),ii
) ->
1955 let (iisb
, lpb
, rpb
, weqb
, iiendb
, iifakestart
, iistob
) =
1957 | iisb
::lpb
::rpb
::weqb
::iiendb
::iifakestart
::iisto
->
1958 (iisb
,lpb
,rpb
,weqb
,iiendb
, iifakestart
,iisto
)
1959 | _
-> raise
(Impossible
28)
1962 then minusize_list iistob
1963 else return ((), iistob
)
1964 ) >>= (fun () iistob
->
1966 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
1967 ident DontKnow sa
(sb
, iisb
) >>= (fun sa
(sb
, iisb
) ->
1968 tokenf lpa lpb
>>= (fun lpa lpb
->
1969 tokenf rpa rpb
>>= (fun rpa rpb
->
1970 tokenf weqa weqb
>>= (fun weqa weqb
->
1971 tokenf enda iiendb
>>= (fun enda iiendb
->
1972 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
1973 initialiser inia inib
>>= (fun inia inib
->
1974 let eas = redots
eas easundots
in
1977 (mckstart
, allminus
,
1978 (A.MacroDeclInit
(sa
,lpa
,eas,rpa
,weqa
,inia
,enda
)) +> A.rewrap decla
),
1979 (B.MacroDeclInit
((sb
,ebs
,inib
),
1980 [iisb
;lpb
;rpb
;iiendb
;iifakestart
] ++ iistob
))
1984 | A.MacroDeclInit
(sa
,lpa
,eas,rpa
,weqa
,inia
,enda
), _
-> fail
1986 | _
, (B.MacroDecl _
|B.MacroDeclInit _
|B.DeclList _
) -> fail
1989 and onedecl
= fun allminus decla
(declb
, iiptvirgb
, iistob
) ->
1990 X.all_bound
(A.get_inherited decla
) >&&>
1991 match A.unwrap decla
, declb
with
1993 (* kind of typedef iso, we must unfold, it's for the case
1994 * T { }; that we want to match against typedef struct { } xx_t;
1997 | A.TyDecl
(tya0
, ptvirga
),
1998 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2000 B.v_storage
= (B.StoTypedef
, inl
);
2003 B.v_type_bis
= typb0bis
;
2006 (match A.unwrap tya0
, typb0
with
2007 | A.Type
(allminus
,cv1
,tya1
), ((qu
,il
),typb1
) ->
2008 (* allminus doesn't seem useful here - nothing done with cv1 *)
2010 (match A.unwrap tya1
, typb1
with
2011 | A.StructUnionDef
(tya2
, lba
, declsa
, rba
),
2012 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
2014 let (iisub
, iisbopt
, lbb
, rbb
) =
2017 let (iisub
, lbb
, rbb
) = tuple_of_list3 ii
in
2018 (iisub
, [], lbb
, rbb
)
2021 "warning: both a typedef (%s) and struct name introduction (%s)"
2022 (Ast_c.str_of_name nameidb
) s
2024 pr2 "warning: I will consider only the typedef";
2025 let (iisub
, iisb
, lbb
, rbb
) = tuple_of_list4 ii
in
2026 (iisub
, [iisb
], lbb
, rbb
)
2029 structdef_to_struct_name
2030 (Ast_c.nQ
, (B.StructUnion
(sub
, sbopt
, declsb
), ii
))
2033 Ast_c.nQ
,((B.TypeName
(nameidb
, Some
2034 (Lib_parsing_c.al_type
structnameb))), [])
2037 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2038 tokenf lba lbb
>>= (fun lba lbb
->
2039 tokenf rba rbb
>>= (fun rba rbb
->
2040 struct_fields
(A.undots declsa
) declsb
>>=(fun undeclsa declsb
->
2041 let declsa = redots
declsa undeclsa
in
2043 (match A.unwrap tya2
with
2044 | A.Type
(allminus
, cv3
, tya3
) -> (* again allminus not used *)
2045 (match A.unwrap tya3
with
2046 | A.MetaType
(ida
,keep
, inherited
) ->
2048 fullType tya2
fake_typeb >>= (fun tya2
fake_typeb ->
2050 A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1 in
2051 let tya0 = A.Type
(allminus
, cv1
, tya1) +> A.rewrap
tya0 in
2054 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
2055 [iisub
] @ iisbopt
@ [lbb
;rbb
] in
2056 let typb0 = ((qu
, il
), typb1) in
2058 match fake_typeb with
2059 | _nQ
, ((B.TypeName
(nameidb
, _typ
)),[]) ->
2062 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
2063 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2065 B.v_storage
= (B.StoTypedef
, inl
);
2068 B.v_type_bis
= typb0bis
;
2070 iivirg
),iiptvirgb
,iistob
)
2072 | _
-> raise
(Impossible
29)
2075 (* do we need EnumName here too? *)
2076 | A.StructUnionName
(sua
, sa
) ->
2077 fullType tya2
structnameb >>= (fun tya2
structnameb ->
2079 let tya1 = A.StructUnionDef
(tya2
,lba
,declsa,rba
)+> A.rewrap
tya1
2081 let tya0 = A.Type
(allminus
, cv1
, tya1) +> A.rewrap
tya0 in
2083 match structnameb with
2084 | _nQ
, (B.StructUnionName
(sub
, s), [iisub
;iisbopt
]) ->
2086 let typb1 = B.StructUnion
(sub
,sbopt
, declsb
),
2087 [iisub
;iisbopt
;lbb
;rbb
] in
2088 let typb0 = ((qu
, il
), typb1) in
2091 (A.TyDecl
(tya0, ptvirga
)) +> A.rewrap decla
,
2092 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2094 B.v_storage
= (B.StoTypedef
, inl
);
2097 B.v_type_bis
= typb0bis
;
2099 iivirg
),iiptvirgb
,iistob
)
2101 | _
-> raise
(Impossible
30)
2103 | _
-> raise
(Impossible
31)
2112 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
2113 ({B.v_namei
= Some
(nameidb
, _
);B.v_storage
= (B.StoTypedef
,_
);}, iivirg
)
2116 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2117 ({B.v_namei
=Some
(nameidb
, _
);B.v_storage
=(B.StoTypedef
,_
);}, iivirg
)
2122 (* could handle iso here but handled in standard.iso *)
2123 | A.UnInit
(stoa
, typa
, ida
, ptvirga
),
2124 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2129 B.v_type_bis
= typbbis
;
2131 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2132 fullType typa typb
>>= (fun typa typb
->
2133 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2134 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2135 (fun stoa
(stob
, iistob
) ->
2137 (A.UnInit
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2138 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2143 B.v_type_bis
= typbbis
;
2148 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2149 ({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
2154 B.v_type_bis
= typbbis
;
2157 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2158 tokenf eqa iieqb
>>= (fun eqa iieqb
->
2159 fullType typa typb
>>= (fun typa typb
->
2160 ident_cpp DontKnow ida nameidb
>>= (fun ida nameidb
->
2161 storage_optional_allminus allminus stoa
(stob
, iistob
) >>=
2162 (fun stoa
(stob
, iistob
) ->
2163 initialiser inia inib
>>= (fun inia inib
->
2165 (A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
)) +> A.rewrap decla
,
2166 (({B.v_namei
= Some
(nameidb
, B.ValInit
(iieqb
, inib
));
2171 B.v_type_bis
= typbbis
;
2176 | A.Init
(stoa
, typa
, ida
, eqa
, inia
, ptvirga
),
2177 ({B.v_namei
= Some
(nameidb
, B.ConstrInit _
);
2182 B.v_type_bis
= typbbis
;
2184 -> fail (* C++ constructor declaration not supported in SmPL *)
2186 (* do iso-by-absence here ? allow typedecl and var ? *)
2187 | A.TyDecl
(typa
, ptvirga
),
2188 ({B.v_namei
= None
; B.v_type
= typb
;
2192 B.v_type_bis
= typbbis
;
2195 if stob
=*= (B.NoSto
, false)
2197 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2198 fullType typa typb
>>= (fun typa typb
->
2200 (A.TyDecl
(typa
, ptvirga
)) +> A.rewrap decla
,
2201 (({B.v_namei
= None
;
2206 B.v_type_bis
= typbbis
;
2207 }, iivirg
), iiptvirgb
, iistob
)
2212 | A.Typedef
(stoa
, typa
, ida
, ptvirga
),
2213 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2215 B.v_storage
= (B.StoTypedef
,inline
);
2218 B.v_type_bis
= typbbis
;
2221 tokenf ptvirga iiptvirgb
>>= (fun ptvirga iiptvirgb
->
2222 fullType typa typb
>>= (fun typa typb
->
2225 tokenf stoa iitypedef
>>= (fun stoa iitypedef
->
2226 return (stoa
, [iitypedef
])
2228 | _
-> error iistob
"weird, have both typedef and inline or nothing";
2229 ) >>= (fun stoa iistob
->
2230 (match A.unwrap ida
with
2231 | A.MetaType
(_
,_
,_
) ->
2234 Ast_c.nQ
, ((B.TypeName
(nameidb
, Ast_c.noTypedefDef
())), [])
2236 fullTypebis ida
fake_typeb >>= (fun ida
fake_typeb ->
2237 match fake_typeb with
2238 | _nQ
, ((B.TypeName
(nameidb
, _typ
)), []) ->
2239 return (ida
, nameidb
)
2240 | _
-> raise
(Impossible
32)
2245 | B.RegularName
(sb
, iidb
) ->
2246 let iidb1 = tuple_of_list1 iidb
in
2250 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
2252 (A.TypeName sa
) +> A.rewrap ida
,
2253 B.RegularName
(sb
, [iidb1])
2257 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
2261 | _
-> raise
(Impossible
33)
2263 ) >>= (fun ida nameidb
->
2265 (A.Typedef
(stoa
, typa
, ida
, ptvirga
)) +> A.rewrap decla
,
2266 (({B.v_namei
= Some
(nameidb
, B.NoInit
);
2268 B.v_storage
= (B.StoTypedef
,inline
);
2271 B.v_type_bis
= typbbis
;
2279 | _
, ({B.v_namei
= None
;}, _
) ->
2280 (* old: failwith "no variable in this declaration, weird" *)
2285 | A.DisjDecl declas
, declb
->
2286 declas
+> List.fold_left
(fun acc decla
->
2288 (* (declaration (mckstart, allminus, decla) declb) *)
2289 (onedecl allminus decla
(declb
,iiptvirgb
, iistob
))
2294 (* only in struct type decls *)
2295 | A.Ddots
(dots
,whencode
), _
->
2296 raise
(Impossible
34)
2298 | A.OptDecl _
, _
| A.UniqueDecl _
, _
->
2299 failwith
"not handling Opt/Unique Decl"
2301 | _
, ({B.v_namei
=Some _
}, _
) ->
2307 (* ------------------------------------------------------------------------- *)
2309 and (initialiser
: (A.initialiser
, Ast_c.initialiser
) matcher
) = fun ia ib
->
2310 X.all_bound
(A.get_inherited ia
) >&&>
2311 match (A.unwrap ia
,ib
) with
2313 | (A.MetaInit
(ida
,keep
,inherited
), ib
) ->
2315 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_ini ib
) in
2316 X.envf keep inherited
(ida
, Ast_c.MetaInitVal ib
, max_min)
2318 X.distrf_ini ida ib
>>= (fun ida ib
->
2320 A.MetaInit
(ida
,keep
,inherited
) +> A.rewrap ia
,
2325 | A.AsInit
(ini
,asini
), inib
->
2326 initialiser ini inib
>>= (fun ini inib
->
2327 initialiser asini inib
>>= (fun asini inib
->
2329 ((A.AsInit
(ini
,asini
)) +> A.rewrap ia
,
2332 | (A.InitExpr expa
, ib
) ->
2333 (match A.unwrap expa
, ib
with
2334 | A.Edots
(mcode, None
), ib
->
2335 X.distrf_ini
(dots2metavar mcode) ib
>>= (fun mcode ib
->
2338 (A.Edots
(metavar2dots mcode, None
) +> A.rewrap expa
)
2343 | A.Edots
(_
, Some expr
), _
-> failwith
"not handling when on Edots"
2345 | _
, (B.InitExpr expb
, ii
) ->
2347 expression expa expb
>>= (fun expa expb
->
2349 (A.InitExpr expa
) +> A.rewrap ia
,
2350 (B.InitExpr expb
, ii
)
2355 | (A.ArInitList
(ia1
, ias
, ia2
), (B.InitList ibs
, ii
)) ->
2357 | ib1::ib2
::iicommaopt
->
2358 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2359 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2360 ar_initialisers
(A.undots ias
) (ibs
, iicommaopt
) >>=
2361 (fun iasundots
(ibs
,iicommaopt
) ->
2363 (A.ArInitList
(ia1
, redots ias iasundots
, ia2
)) +> A.rewrap ia
,
2364 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2367 | _
-> raise
(Impossible
35)
2370 | (A.StrInitList
(allminus
, ia1
, ias
, ia2
, []), (B.InitList ibs
, ii
)) ->
2372 | ib1::ib2
::iicommaopt
->
2373 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2374 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2375 str_initialisers allminus ias
(ibs
, iicommaopt
) >>=
2376 (fun ias
(ibs
,iicommaopt
) ->
2378 (A.StrInitList
(allminus
, ia1
, ias
, ia2
, [])) +> A.rewrap ia
,
2379 (B.InitList ibs
, ib1::ib2
::iicommaopt
)
2382 | _
-> raise
(Impossible
36)
2385 | (A.StrInitList
(allminus
, i1
, ias
, i2
, whencode
),
2386 (B.InitList ibs
, _ii
)) ->
2387 failwith
"TODO: not handling whencode in initialisers"
2390 | (A.InitGccExt
(designatorsa
, ia2
, inia
),
2391 (B.InitDesignators
(designatorsb
, inib
), ii2
))->
2393 let iieq = tuple_of_list1 ii2
in
2395 tokenf ia2
iieq >>= (fun ia2
iieq ->
2396 designators designatorsa designatorsb
>>=
2397 (fun designatorsa designatorsb
->
2398 initialiser inia inib
>>= (fun inia inib
->
2400 (A.InitGccExt
(designatorsa
, ia2
, inia
)) +> A.rewrap ia
,
2401 (B.InitDesignators
(designatorsb
, inib
), [iieq])
2407 | (A.InitGccName
(ida
, ia1
, inia
), (B.InitFieldOld
(idb
, inib
), ii
)) ->
2410 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2411 initialiser inia inib
>>= (fun inia inib
->
2412 tokenf ia1 iicolon
>>= (fun ia1 iicolon
->
2414 (A.InitGccName
(ida
, ia1
, inia
)) +> A.rewrap ia
,
2415 (B.InitFieldOld
(idb
, inib
), [iidb
;iicolon
])
2422 | A.IComma
(comma
), _
->
2423 raise
(Impossible
37)
2425 | A.UniqueIni _
,_
| A.OptIni _
,_
->
2426 failwith
"not handling Opt/Unique on initialisers"
2428 | _
, (B.InitIndexOld
(_
, _
), _
) -> fail
2429 | _
, (B.InitFieldOld
(_
, _
), _
) -> fail
2431 | _
, ((B.InitDesignators
(_
, _
)|B.InitList _
|B.InitExpr _
), _
)
2434 and designators dla dlb
=
2435 match (dla
,dlb
) with
2436 ([],[]) -> return ([], [])
2437 | ([],_
) | (_
,[]) -> fail
2438 | (da
::dla
,db
::dlb
) ->
2439 designator da db
>>= (fun da db
->
2440 designators dla dlb
>>= (fun dla dlb
->
2441 return (da
::dla
, db
::dlb
)))
2443 and designator da db
=
2445 (A.DesignatorField
(ia1
, ida
), (B.DesignatorField idb
,ii1
)) ->
2447 let (iidot
, iidb
) = tuple_of_list2 ii1
in
2448 tokenf ia1 iidot
>>= (fun ia1 iidot
->
2449 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
2451 A.DesignatorField
(ia1
, ida
),
2452 (B.DesignatorField idb
, [iidot
;iidb
])
2455 | (A.DesignatorIndex
(ia1
,ea
,ia2
), (B.DesignatorIndex eb
, ii1
)) ->
2457 let (ib1, ib2
) = tuple_of_list2 ii1
in
2458 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2459 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2460 expression ea eb
>>= (fun ea eb
->
2462 A.DesignatorIndex
(ia1
,ea
,ia2
),
2463 (B.DesignatorIndex eb
, [ib1;ib2
])
2466 | (A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2467 (B.DesignatorRange
(e1b
, e2b
), ii1
)) ->
2469 let (ib1, ib2
, ib3
) = tuple_of_list3 ii1
in
2470 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
2471 tokenf ia2 ib2
>>= (fun ia2 ib2
->
2472 tokenf ia3 ib3
>>= (fun ia3 ib3
->
2473 expression e1a e1b
>>= (fun e1a e1b
->
2474 expression e2a e2b
>>= (fun e2a e2b
->
2476 A.DesignatorRange
(ia1
,e1a
,ia2
,e2a
,ia3
),
2477 (B.DesignatorRange
(e1b
, e2b
), [ib1;ib2
;ib3
])
2479 | (_
, ((B.DesignatorField _
|B.DesignatorIndex _
|B.DesignatorRange _
), _
)) ->
2482 and str_initialisers
= fun allminus ias
(ibs
, iicomma
) ->
2483 let ias_unsplit = unsplit_icomma ias
in
2484 let ibs_split = resplit_initialiser ibs iicomma
in
2486 if need_unordered_initialisers ibs
2488 initialisers_unordered2 allminus
ias_unsplit ibs_split >>=
2489 (fun ias_unsplit ibs_split ->
2491 split_icomma ias_unsplit,
2492 unsplit_initialiser ibs_split))
2495 and ar_initialisers
= fun ias
(ibs
, iicomma
) ->
2496 (* this doesn't check need_unordered_initialisers because ... can be
2497 implemented as ordered, even if it matches unordered initializers *)
2498 let ibs = resplit_initialiser ibs iicomma
in
2501 (List.map
(function (elem
,comma
) -> [Left elem
; Right
[comma
]]) ibs) in
2502 initialisers_ordered2 ias
ibs >>=
2503 (fun ias
ibs_split ->
2505 match List.rev
ibs_split with
2506 (Right comma
)::rest
-> (Ast_c.unsplit_comma
(List.rev rest
),comma
)
2507 | (Left _
)::_
-> (Ast_c.unsplit_comma
ibs_split,[]) (* possible *)
2509 return (ias
, (ibs,iicomma
)))
2511 and initialisers_ordered2
= fun ias
ibs ->
2513 match A.unwrap ea
with
2514 A.Idots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2516 let build_dots (mcode, optexpr
) = A.Idots
(mcode, optexpr
) in
2517 let match_comma ea
=
2518 match A.unwrap ea
with
2519 A.IComma ia1
-> Some ia1
2521 let build_comma ia1
= A.IComma ia1
in
2522 let match_metalist ea
=
2523 match A.unwrap ea
with
2524 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) ->
2525 Some
(ida
,leninfo
,keep
,inherited
,None
)
2527 let build_metalist _
(ida
,leninfo
,keep
,inherited
) =
2528 A.MetaInitList
(ida
,leninfo
,keep
,inherited
) in
2529 let mktermval v
= Ast_c.MetaInitListVal v
in
2530 let special_cases ea
eas ebs
= None
in
2531 let no_ii x
= failwith
"not possible" in
2532 list_matcher match_dots build_dots match_comma build_comma
2533 match_metalist build_metalist mktermval
2534 special_cases initialiser
X.distrf_inis
no_ii
2535 (function x
-> x
) ias
ibs
2537 and initialisers_unordered2
= fun allminus ias
ibs ->
2542 let rec loop = function
2543 [] -> return ([],[])
2544 | (ib
,comma
)::ibs ->
2545 X.distrf_ini
minusizer ib
>>= (fun _ ib
->
2546 tokenf minusizer comma
>>= (fun _ comma
->
2547 loop ibs >>= (fun l
ibs ->
2548 return(l
,(ib
,comma
)::ibs)))) in
2550 else return ([], ys
)
2552 let permut = Common.uncons_permut_lazy ys
in
2553 permut +> List.fold_left
(fun acc
((e
, pos
), rest
) ->
2555 (initialiser_comma x e
2557 let rest = Lazy.force
rest in
2558 initialisers_unordered2 allminus xs
rest >>= (fun xs
rest ->
2561 Common.insert_elem_pos
(e
, pos
) rest
2565 and initialiser_comma
(x
,xcomma
) (y
, commay
) =
2566 match A.unwrap xcomma
with
2568 tokenf commax commay
>>= (fun commax commay
->
2569 initialiser x y
>>= (fun x y
->
2571 (x
, (A.IComma commax
) +> A.rewrap xcomma
),
2573 | _
-> raise
(Impossible
38) (* unsplit_iicomma wrong *)
2575 (* ------------------------------------------------------------------------- *)
2576 and (struct_fields
: (A.declaration list
, B.field list
) matcher
) =
2579 match A.unwrap ea
with
2580 A.Ddots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2582 let build_dots (mcode, optexpr
) = A.Ddots
(mcode, optexpr
) in
2583 let match_comma ea
= None
in
2584 let build_comma ia1
= failwith
"not possible" in
2585 let match_metalist ea
=
2586 match A.unwrap ea
with
2587 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) ->
2588 Some
(ida
,leninfo
,keep
,inherited
,None
)
2590 let build_metalist _
(ida
,leninfo
,keep
,inherited
) =
2591 A.MetaFieldList
(ida
,leninfo
,keep
,inherited
) in
2593 (* drop empty ii information, because nothing between elements *)
2594 let v = List.map
Ast_c.unwrap
v in
2595 Ast_c.MetaFieldListVal
v in
2596 let special_cases ea
eas ebs
= None
in
2597 let no_ii x
= failwith
"not possible" in
2598 let make_ebs ebs
= List.map
(function x
-> Left x
) ebs
in
2599 let unmake_ebs ebs
=
2600 List.map
(function Left x
-> x
| Right x
-> failwith
"no right") ebs
in
2601 let distrf mcode startxs =
2602 let startxs = unmake_ebs startxs in
2603 X.distrf_struct_fields
mcode startxs >>=
2604 (fun mcode startxs -> return (mcode,make_ebs startxs)) in
2605 let filter_fields l
=
2608 match Ast_c.unwrap x
with
2609 Ast_c.DeclarationField fld
-> true
2610 | Ast_c.EmptyField info
-> true
2611 | Ast_c.MacroDeclField decl
-> true
2612 | Ast_c.CppDirectiveStruct cpp
-> false
2613 | Ast_c.IfdefStruct ifdef
-> false)
2615 list_matcher match_dots build_dots match_comma build_comma
2616 match_metalist build_metalist mktermval
2617 special_cases struct_field
distrf no_ii
2618 filter_fields eas (make_ebs ebs
) >>=
2619 (fun eas ebs
-> return (eas,unmake_ebs ebs
))
2621 and (struct_field
: (A.declaration
, B.field
) matcher
) = fun fa fb
->
2623 match A.unwrap fa
,fb
with
2624 | A.MetaField
(ida
,keep
,inherited
), _
->
2626 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_field fb
) in
2627 X.envf keep inherited
(ida
, Ast_c.MetaFieldVal fb
, max_min) (fun () ->
2628 X.distrf_field ida fb
2629 ) >>= (fun ida fb
->
2630 return ((A.MetaField
(ida
, keep
, inherited
))+> A.rewrap fa
,
2632 | _
,B.DeclarationField
(B.FieldDeclList
(onefield_multivars
,iiptvirg
)) ->
2634 let iiptvirgb = tuple_of_list1 iiptvirg
in
2636 (match onefield_multivars
with
2637 | [] -> raise
(Impossible
39)
2638 | [onevar
,iivirg
] ->
2639 assert (null iivirg
);
2641 | B.BitField
(sopt
, typb
, _
, expr
) ->
2642 pr2_once
"warning: bitfield not handled by ast_cocci";
2644 | B.Simple
(None
, typb
) ->
2645 pr2_once
"warning: unnamed struct field not handled by ast_cocci";
2647 | B.Simple
(Some nameidb
, typb
) ->
2649 (* build a declaration from a struct field *)
2650 let allminus = false in
2652 let stob = B.NoSto
, false in
2654 ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2657 B.v_local
= Ast_c.NotLocalDecl
;
2658 B.v_attr
= Ast_c.noattr
;
2659 B.v_type_bis
= ref None
;
2660 (* the struct field should also get expanded ? no it's not
2661 * important here, we will rematch very soon *)
2665 onedecl
allminus fa
(fake_var,iiptvirgb,iisto) >>=
2666 (fun fa
(var
,iiptvirgb,iisto) ->
2669 | ({B.v_namei
= Some
(nameidb
, B.NoInit
);
2674 let onevar = B.Simple
(Some nameidb
, typb
) in
2678 ((B.DeclarationField
2679 (B.FieldDeclList
([onevar, iivirg
], [iiptvirgb])))
2682 | _
-> raise
(Impossible
40)
2687 pr2_once
"PB: More that one variable in decl. Have to split";
2690 | _
,B.EmptyField _iifield
->
2693 | A.MacroDecl
(sa
,lpa
,eas,rpa
,enda
),B.MacroDeclField
((sb
,ebs
),ii
) ->
2695 | _
,B.MacroDeclField
((sb
,ebs
),ii
) -> fail
2697 | _
,B.CppDirectiveStruct directive
-> fail
2698 | _
,B.IfdefStruct directive
-> fail
2701 and enum_fields
= fun eas ebs
->
2703 match A.unwrap ea
with
2704 A.Edots
(mcode, optexpr
) -> Some
(mcode, optexpr
)
2706 let build_dots (mcode, optexpr
) = A.Edots
(mcode, optexpr
) in
2707 let match_comma ea
=
2708 match A.unwrap ea
with
2709 A.EComma ia1
-> Some ia1
2711 let build_comma ia1
= A.EComma ia1
in
2712 let match_metalist ea
= None
in
2713 let build_metalist _
(ida
,leninfo
,keep
,inherited
) =
2714 failwith
"not possible" in
2715 let mktermval v = failwith
"not possible" in
2716 let special_cases ea
eas ebs
= None
in
2717 list_matcher match_dots build_dots match_comma build_comma
2718 match_metalist build_metalist mktermval
2719 special_cases enum_field
X.distrf_enum_fields
2720 Lib_parsing_c.ii_of_enum_fields
(function x
-> x
) eas ebs
2722 and enum_field ida idb
=
2723 X.all_bound
(A.get_inherited ida
) >&&>
2724 match A.unwrap ida
, idb
with
2725 A.Ident
(id
),(nameidb
,None
) ->
2726 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2727 return ((A.Ident id
) +> A.rewrap ida
, (nameidb
,None
)))
2728 | A.Ident
(id
),(nameidb
,Some _
) -> fail (* should we have an iso? *)
2729 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,Some
(opbi,eb2
)) ->
2730 (match A.unwrap ea1
with
2732 ident_cpp DontKnow id nameidb
>>= (fun id nameidb
->
2733 expression ea2 eb2
>>= (fun ea2 eb2
->
2734 tokenf opa
opbi >>= (fun opa
opbi -> (* only one kind of assignop *)
2736 (A.Assignment
((A.Ident
(id
))+>A.rewrap ea1
,opa
,ea2
,init
)) +>
2738 (nameidb
,Some
(opbi,eb2
))))))
2739 | _
-> failwith
"not possible")
2740 | A.Assignment
(ea1
,opa
,ea2
,init
),(nameidb
,None
) -> fail
2741 | _
-> failwith
("not possible: "^
(Dumper.dump
(A.unwrap ida
)))
2743 (* ------------------------------------------------------------------------- *)
2744 and (fullType
: (A.fullType
, Ast_c.fullType
) matcher
) =
2746 X.optional_qualifier_flag
(fun optional_qualifier
->
2747 X.all_bound
(A.get_inherited typa
) >&&>
2748 match A.unwrap typa
, typb
with
2749 | A.Type
(allminus,cv
,ty1
), ((qu
,il
),ty2
) ->
2751 if qu
.B.const
&& qu
.B.volatile
2754 ("warning: the type is both const & volatile but cocci " ^
2755 "does not handle that");
2757 (* Drop out the const/volatile part that has been matched.
2758 * This is because a SP can contain const T v; in which case
2759 * later in match_t_t when we encounter a T, we must not add in
2760 * the environment the whole type.
2765 (* "iso-by-absence" *)
2768 fullTypebis ty1
((qu
,il
), ty2
) >>= (fun ty1
((qu
,il
), ty2
) ->
2770 then minusize_list il
2771 else return ((), il
)
2774 (A.Type
(allminus, None
, ty1
)) +> A.rewrap typa
,
2778 (match optional_qualifier
, qu
.B.const
|| qu
.B.volatile
with
2779 | false, false -> do_stuff ()
2780 | false, true -> fail
2781 | true, false -> do_stuff ()
2784 then pr2_once
"USING optional_qualifier builtin isomorphism";
2790 (* todo: can be __const__ ? can be const & volatile so
2791 * should filter instead ?
2793 (match term x
, il
with
2794 | A.Const
, [i1
] when qu
.B.const
->
2796 tokenf x i1
>>= (fun x i1
->
2797 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2799 (A.Type
(allminus, Some x
, ty1
)) +> A.rewrap typa
,
2803 | A.Volatile
, [i1
] when qu
.B.volatile
->
2804 tokenf x i1
>>= (fun x i1
->
2805 fullTypebis ty1
(Ast_c.nQ
,ty2
) >>= (fun ty1
(_
, ty2
) ->
2807 (A.Type
(allminus, Some x
, ty1
)) +> A.rewrap typa
,
2815 | A.AsType
(ty
,asty
), tyb
->
2816 fullType ty tyb
>>= (fun ty tyb
->
2817 fullType asty tyb
>>= (fun asty tyb
->
2819 ((A.AsType
(ty
,asty
)) +> A.rewrap typa
,
2822 | A.DisjType typas
, typb
->
2824 List.fold_left
(fun acc typa
-> acc
>|+|> (fullType typa typb
)) fail
2826 | A.OptType
(_
), _
| A.UniqueType
(_
), _
2827 -> failwith
"not handling Opt/Unique on type"
2832 * Why not (A.typeC, Ast_c.typeC) matcher ?
2833 * because when there is MetaType, we want that T record the whole type,
2834 * including the qualifier, and so this type (and the new_il function in
2835 * preceding function).
2838 and (fullTypebis
: (A.typeC
, Ast_c.fullType
) matcher
) =
2840 X.all_bound
(A.get_inherited ta
) >&&>
2841 match A.unwrap ta
, tb
with
2844 | A.MetaType
(ida
,keep
, inherited
), typb
->
2846 let (tyq
, (ty
, tyii
)) = typb
in
2853 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
2854 X.envf keep inherited
(ida
, B.MetaTypeVal typb
, max_min) (fun () ->
2855 X.distrf_type ida typb
>>= (fun ida typb
->
2857 A.MetaType
(ida
,keep
, inherited
) +> A.rewrap ta
,
2859 else fail (* K&R, or macro, or C++? *)
2860 | unwrap
, (qub
, typb
) ->
2861 typeC ta typb
>>= (fun ta typb
->
2862 return (ta
, (qub
, typb
))
2865 and simulate_signed ta basea stringsa signaopt tb baseb ii rebuilda
=
2866 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2867 * And even if in baseb we have a Signed Int, that does not mean
2868 * that ii is of length 2, cos Signed is the default, so if in signa
2869 * we have Signed explicitly ? we cant "accrocher" this mcode to
2870 * something :( So for the moment when there is signed in cocci,
2871 * we force that there is a signed in c too (done in pattern.ml).
2873 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2876 (* handle some iso on type ? (cf complex C rule for possible implicit
2878 match basea
, baseb
with
2879 | A.VoidType
, B.Void
2880 | A.FloatType
, B.FloatType
(B.CFloat
)
2881 | A.DoubleType
, B.FloatType
(B.CDouble
)
2882 | A.SizeType
, B.SizeType
2883 | A.SSizeType
, B.SSizeType
2884 | A.PtrDiffType
,B.PtrDiffType
->
2885 assert (signaopt
=*= None
);
2886 let stringa = tuple_of_list1 stringsa
in
2887 let (ibaseb
) = tuple_of_list1 ii
in
2888 tokenf stringa ibaseb
>>= (fun stringa ibaseb
->
2890 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2891 (B.BaseType baseb
, [ibaseb
])
2894 | A.CharType
, B.IntType
B.CChar
when signaopt
=*= None
->
2895 let stringa = tuple_of_list1 stringsa
in
2896 let ibaseb = tuple_of_list1 ii
in
2897 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2899 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2900 (B.BaseType
(B.IntType
B.CChar
), [ibaseb])
2903 | A.CharType
,B.IntType
(B.Si
(_sign
, B.CChar2
)) when signaopt
<> None
->
2904 let stringa = tuple_of_list1 stringsa
in
2905 let ibaseb = tuple_of_list1 iibaseb
in
2906 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2907 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2909 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2910 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2913 | A.ShortType
, B.IntType
(B.Si
(_
, B.CShort
))
2914 | A.IntType
, B.IntType
(B.Si
(_
, B.CInt
))
2915 | A.LongType
, B.IntType
(B.Si
(_
, B.CLong
)) ->
2916 let stringa = tuple_of_list1 stringsa
in
2919 (* iso-by-presence ? *)
2920 (* when unsigned int in SP, allow have just unsigned in C ? *)
2921 if mcode_contain_plus (mcodekind stringa)
2925 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2927 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2928 (B.BaseType
(baseb
), iisignbopt
++ [])
2934 "warning: long int or short int not handled by ast_cocci";*)
2938 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2939 tokenf stringa ibaseb >>= (fun stringa ibaseb ->
2941 (rebuilda
([stringa], signaopt
)) +> A.rewrap ta
,
2942 (B.BaseType
(baseb
), iisignbopt
++ [ibaseb])
2944 | _
-> raise
(Impossible
41)
2948 | A.LongLongIntType
, B.IntType
(B.Si
(_
, B.CLongLong
)) ->
2949 let (string1a
,string2a
,string3a
) = tuple_of_list3 stringsa
in
2951 [ibase1b
;ibase2b
;ibase3b
] ->
2952 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2953 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2954 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2955 tokenf string3a ibase3b
>>= (fun base3a ibase3b
->
2957 (rebuilda
([base1a
;base2a
;base3a
], signaopt
)) +> A.rewrap ta
,
2958 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
;ibase3b
])
2960 | [ibase1b
;ibase2b
] -> fail (* int omitted *)
2961 | [] -> fail (* should something be done in this case? *)
2962 | _
-> raise
(Impossible
42))
2965 | A.LongLongType
, B.IntType
(B.Si
(_
, B.CLongLong
))
2966 | A.LongIntType
, B.IntType
(B.Si
(_
, B.CLong
))
2967 | A.ShortIntType
, B.IntType
(B.Si
(_
, B.CShort
))
2968 | A.LongDoubleType
, B.FloatType
B.CLongDouble
->
2969 let (string1a
,string2a
) = tuple_of_list2 stringsa
in
2971 [ibase1b
;ibase2b
] ->
2972 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2973 tokenf string1a ibase1b
>>= (fun base1a ibase1b
->
2974 tokenf string2a ibase2b
>>= (fun base2a ibase2b
->
2976 (rebuilda
([base1a
;base2a
], signaopt
)) +> A.rewrap ta
,
2977 (B.BaseType
(baseb
), iisignbopt
++ [ibase1b
;ibase2b
])
2979 | [ibase1b
] -> fail (* short or long *)
2980 | [ibase1b
;ibase2b
;ibase3b
] -> fail (* long long case *)
2981 | [] -> fail (* should something be done in this case? *)
2982 | _
-> raise
(Impossible
43))
2984 | _
, (B.Void
|B.FloatType _
|B.IntType _
2985 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
2987 and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda
=
2988 (* In ii there is a list, sometimes of length 1 or 2 or 3.
2989 * And even if in baseb we have a Signed Int, that does not mean
2990 * that ii is of length 2, cos Signed is the default, so if in signa
2991 * we have Signed explicitely ? we cant "accrocher" this mcode to
2992 * something :( So for the moment when there is signed in cocci,
2993 * we force that there is a signed in c too (done in pattern.ml).
2995 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
2997 let match_to_type rebaseb
=
2998 sign signaopt
signbopt >>= (fun signaopt iisignbopt
->
2999 let fta = A.rewrap basea
(A.Type
(false(*don't know*),None
,basea
)) in
3000 let ftb = Ast_c.nQ
,(B.BaseType
(rebaseb
), iibaseb
) in
3001 fullType
fta ftb >>= (fun fta (_
,tb
) ->
3002 (match A.unwrap
fta,tb
with
3003 A.Type
(_
,_
,basea
), (B.BaseType baseb
, ii
) ->
3005 (rebuilda
(basea
, signaopt
)) +> A.rewrap ta
,
3006 (B.BaseType
(baseb
), iisignbopt
++ ii
)
3008 | _
-> failwith
"not possible"))) in
3010 (* handle some iso on type ? (cf complex C rule for possible implicit
3013 | B.IntType
(B.Si
(_sign
, B.CChar2
)) ->
3014 match_to_type (B.IntType
B.CChar
)
3016 | B.IntType
(B.Si
(_
, ty
)) ->
3018 | [] -> fail (* metavariable has to match something *)
3020 | _
-> match_to_type (B.IntType
(B.Si
(B.Signed
, ty
)))
3024 | (B.Void
|B.FloatType _
|B.IntType _
3025 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3027 and (typeC
: (A.typeC
, Ast_c.typeC
) matcher
) =
3029 match A.unwrap ta
, tb
with
3030 | A.BaseType
(basea
,stringsa
), (B.BaseType baseb
, ii
) ->
3031 simulate_signed ta basea stringsa None tb baseb ii
3032 (function (stringsa
, signaopt
) -> A.BaseType
(basea
,stringsa
))
3033 | A.SignedT
(signaopt
, Some basea
), (B.BaseType baseb
, ii
) ->
3034 (match A.unwrap basea
with
3035 A.BaseType
(basea1
,strings1
) ->
3036 simulate_signed ta basea1 strings1
(Some signaopt
) tb baseb ii
3037 (function (strings1
, Some signaopt
) ->
3040 Some
(A.rewrap basea
(A.BaseType
(basea1
,strings1
))))
3041 | _
-> failwith
"not possible")
3042 | A.MetaType
(ida
,keep
,inherited
) ->
3043 simulate_signed_meta ta basea
(Some signaopt
) tb baseb ii
3044 (function (basea
, Some signaopt
) ->
3045 A.SignedT
(signaopt
,Some basea
)
3046 | _
-> failwith
"not possible")
3047 | _
-> failwith
"not possible")
3048 | A.SignedT
(signa
,None
), (B.BaseType baseb
, ii
) ->
3049 let signbopt, iibaseb
= split_signb_baseb_ii (baseb
, ii
) in
3050 (match iibaseb
, baseb
with
3051 | [], B.IntType
(B.Si
(_sign
, B.CInt
)) ->
3052 sign
(Some signa
) signbopt >>= (fun signaopt iisignbopt
->
3054 | None
-> raise
(Impossible
45)
3057 (A.SignedT
(signa
,None
)) +> A.rewrap ta
,
3058 (B.BaseType baseb
, iisignbopt
)
3066 (* todo? iso with array *)
3067 | A.Pointer
(typa
, iamult
), (B.Pointer typb
, ii
) ->
3068 let (ibmult
) = tuple_of_list1 ii
in
3069 fullType typa typb
>>= (fun typa typb
->
3070 tokenf iamult ibmult
>>= (fun iamult ibmult
->
3072 (A.Pointer
(typa
, iamult
)) +> A.rewrap ta
,
3073 (B.Pointer typb
, [ibmult
])
3076 | A.FunctionType
(allminus,tyaopt
,lpa
,paramsa
,rpa
),
3077 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
) ->
3079 let (lpb
, rpb
) = tuple_of_list2 ii
in
3083 ("Not handling well variable length arguments func. "^
3084 "You have been warned");
3085 tokenf lpa lpb
>>= (fun lpa lpb
->
3086 tokenf rpa rpb
>>= (fun rpa rpb
->
3087 fullType_optional_allminus
allminus tyaopt tyb
>>= (fun tyaopt tyb
->
3088 parameters
(seqstyle paramsa
) (A.undots paramsa
) paramsb
>>=
3089 (fun paramsaundots paramsb
->
3090 let paramsa = redots
paramsa paramsaundots
in
3092 (A.FunctionType
(allminus,tyaopt
,lpa
,paramsa,rpa
) +> A.rewrap ta
,
3093 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), [lpb
;rpb
])
3101 | A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
),
3102 (B.ParenType t1
, ii
) ->
3103 let (lp1b
, rp1b
) = tuple_of_list2 ii
in
3104 let (qu1b
, t1b
) = t1
in
3106 | B.Pointer t2
, ii
->
3107 let (starb
) = tuple_of_list1 ii
in
3108 let (qu2b
, t2b
) = t2
in
3110 | B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))), ii
->
3111 let (lp2b
, rp2b
) = tuple_of_list2 ii
in
3116 ("Not handling well variable length arguments func. "^
3117 "You have been warned");
3119 fullType tya tyb
>>= (fun tya tyb
->
3120 tokenf lp1a lp1b
>>= (fun lp1a lp1b
->
3121 tokenf rp1a rp1b
>>= (fun rp1a rp1b
->
3122 tokenf lp2a lp2b
>>= (fun lp2a lp2b
->
3123 tokenf rp2a rp2b
>>= (fun rp2a rp2b
->
3124 tokenf stara starb
>>= (fun stara starb
->
3125 parameters
(seqstyle paramsa) (A.undots
paramsa) paramsb
>>=
3126 (fun paramsaundots paramsb
->
3127 let paramsa = redots
paramsa paramsaundots
in
3131 (B.FunctionType
(tyb
, (paramsb
, (isvaargs
, iidotsb
))),
3136 (B.Pointer
t2, [starb
]))
3140 (A.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa,rp2a
))
3142 (B.ParenType
t1, [lp1b
;rp1b
])
3155 (* todo: handle the iso on optional size specification ? *)
3156 | A.Array
(typa
, ia1
, eaopt
, ia2
), (B.Array
(ebopt
, typb
), ii
) ->
3157 let (ib1, ib2
) = tuple_of_list2 ii
in
3158 fullType typa typb
>>= (fun typa typb
->
3159 option expression eaopt ebopt
>>= (fun eaopt ebopt
->
3160 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
3161 tokenf ia2 ib2
>>= (fun ia2 ib2
->
3163 (A.Array
(typa
, ia1
, eaopt
, ia2
)) +> A.rewrap ta
,
3164 (B.Array
(ebopt
, typb
), [ib1;ib2
])
3168 (* todo: could also match a Struct that has provided a name *)
3169 (* This is for the case where the SmPL code contains "struct x", without
3170 a definition. In this case, the name field is always present.
3171 This case is also called from the case for A.StructUnionDef when
3172 a name is present in the C code. *)
3173 | A.StructUnionName
(sua
, Some sa
), (B.StructUnionName
(sub
, sb
), ii
) ->
3174 (* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
3175 let (ib1, ib2
) = tuple_of_list2 ii
in
3176 if equal_structUnion (term sua
) sub
3178 ident DontKnow sa
(sb
, ib2
) >>= (fun sa
(sb
, ib2
) ->
3179 tokenf sua
ib1 >>= (fun sua
ib1 ->
3181 (A.StructUnionName
(sua
, Some sa
)) +> A.rewrap ta
,
3182 (B.StructUnionName
(sub
, sb
), [ib1;ib2
])
3187 | A.StructUnionDef
(ty
, lba
, declsa, rba
),
3188 (B.StructUnion
(sub
, sbopt
, declsb
), ii
) ->
3190 let (ii_sub_sb
, lbb
, rbb
) =
3192 [iisub
; lbb
; rbb
] -> (Common.Left iisub
,lbb
,rbb
)
3193 | [iisub
; iisb
; lbb
; rbb
] -> (Common.Right
(iisub
,iisb
),lbb
,rbb
)
3194 | _
-> error ii
"list of length 3 or 4 expected" in
3197 match (sbopt
,ii_sub_sb
) with
3198 (None
,Common.Left iisub
) ->
3199 (* the following doesn't reconstruct the complete SP code, just
3200 the part that matched *)
3202 match A.unwrap
s with
3203 A.Type
(allminus,None
,ty
) ->
3204 (match A.unwrap ty
with
3205 A.StructUnionName
(sua
, None
) ->
3206 (match (term sua
, sub
) with
3208 | (A.Union
,B.Union
) -> return ((),())
3211 tokenf sua iisub
>>= (fun sua iisub
->
3213 A.Type
(allminus,None
,
3214 A.StructUnionName
(sua
, None
) +> A.rewrap
ty)
3216 return (ty,[iisub
])))
3218 | A.DisjType
(disjs
) ->
3220 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3224 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3226 (* build a StructUnionName from a StructUnion *)
3227 let fake_su = B.nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) in
3229 fullType
ty fake_su >>= (fun ty fake_su ->
3231 | _nQ
, (B.StructUnionName
(sub
, sb
), [iisub
;iisb
]) ->
3232 return (ty, [iisub
; iisb
])
3233 | _
-> raise
(Impossible
46))
3237 >>= (fun ty ii_sub_sb
->
3239 tokenf lba lbb
>>= (fun lba lbb
->
3240 tokenf rba rbb
>>= (fun rba rbb
->
3241 struct_fields
(A.undots
declsa) declsb
>>=(fun undeclsa declsb
->
3242 let declsa = redots
declsa undeclsa
in
3245 (A.StructUnionDef
(ty, lba
, declsa, rba
)) +> A.rewrap ta
,
3246 (B.StructUnion
(sub
, sbopt
, declsb
),ii_sub_sb
@[lbb
;rbb
])
3250 (* todo? handle isomorphisms ? because Unsigned Int can be match on a
3251 * uint in the C code. But some CEs consists in renaming some types,
3252 * so we don't want apply isomorphisms every time.
3254 | A.TypeName sa
, (B.TypeName
(nameb
, typb
), noii
) ->
3258 | B.RegularName
(sb
, iidb
) ->
3259 let iidb1 = tuple_of_list1 iidb
in
3263 tokenf sa
iidb1 >>= (fun sa
iidb1 ->
3265 (A.TypeName sa
) +> A.rewrap ta
,
3266 (B.TypeName
(B.RegularName
(sb
, [iidb1]), typb
), noii
)
3270 | B.CppConcatenatedName _
| B.CppVariadicName _
|B.CppIdentBuilder _
3275 | _
, (B.NoType
, ii
) -> fail
3276 | _
, (B.TypeOfExpr e
, ii
) -> fail
3277 | _
, (B.TypeOfType e
, ii
) -> fail
3279 | _
, (B.ParenType e
, ii
) -> fail (* todo ?*)
3280 | A.EnumName
(en
,Some namea
), (B.EnumName nameb
, ii
) ->
3281 let (ib1,ib2
) = tuple_of_list2 ii
in
3282 ident DontKnow namea
(nameb
, ib2
) >>= (fun namea
(nameb
, ib2
) ->
3283 tokenf en
ib1 >>= (fun en
ib1 ->
3285 (A.EnumName
(en
, Some namea
)) +> A.rewrap ta
,
3286 (B.EnumName nameb
, [ib1;ib2
])
3289 | A.EnumDef
(ty, lba
, idsa
, rba
),
3290 (B.Enum
(sbopt
, idsb
), ii
) ->
3292 let (ii_sub_sb
, lbb
, rbb
, comma_opt
) =
3294 [iisub
; lbb
; rbb
; comma_opt
] ->
3295 (Common.Left iisub
,lbb
,rbb
,comma_opt
)
3296 | [iisub
; iisb
; lbb
; rbb
; comma_opt
] ->
3297 (Common.Right
(iisub
,iisb
),lbb
,rbb
,comma_opt
)
3298 | _
-> error ii
"list of length 4 or 5 expected" in
3301 match (sbopt
,ii_sub_sb
) with
3302 (None
,Common.Left iisub
) ->
3303 (* the following doesn't reconstruct the complete SP code, just
3304 the part that matched *)
3306 match A.unwrap
s with
3307 A.Type
(allminus,None
,ty) ->
3308 (match A.unwrap
ty with
3309 A.EnumName
(sua
, None
) ->
3310 tokenf sua iisub
>>= (fun sua iisub
->
3312 A.Type
(allminus,None
,A.EnumName
(sua
, None
) +>
3315 return (ty,[iisub
]))
3317 | A.DisjType
(disjs
) ->
3319 List.fold_left
(fun acc disj
-> acc
>|+|> (loop disj
)) fail
3323 | (Some sb
,Common.Right
(iisub
,iisb
)) ->
3325 (* build an EnumName from an Enum *)
3326 let fake_su = B.nQ
, (B.EnumName sb
, [iisub
;iisb
]) in
3328 fullType
ty fake_su >>= (fun ty fake_su ->
3330 | _nQ
, (B.EnumName sb
, [iisub
;iisb
]) ->
3331 return (ty, [iisub
; iisb
])
3332 | _
-> raise
(Impossible
47))
3336 >>= (fun ty ii_sub_sb
->
3338 tokenf lba lbb
>>= (fun lba lbb
->
3339 tokenf rba rbb
>>= (fun rba rbb
->
3340 let idsb = resplit_initialiser idsb [comma_opt
] in
3344 (function (elem
,comma
) -> [Left elem
; Right
[comma
]])
3346 enum_fields
(A.undots idsa
) idsb >>= (fun unidsa
idsb ->
3347 let idsa = redots
idsa unidsa
in
3349 match List.rev
idsb with
3350 (Right comma
)::rest ->
3351 (Ast_c.unsplit_comma
(List.rev
rest),comma
)
3352 | (Left _
)::_
-> (Ast_c.unsplit_comma
idsb,[]) (* possible *)
3355 (A.EnumDef
(ty, lba
, idsa, rba
)) +> A.rewrap ta
,
3356 (B.Enum
(sbopt
, idsb),ii_sub_sb
@[lbb
;rbb
]@iicomma
)
3360 | _
, (B.Enum _
, _
) -> fail (* todo cocci ?*)
3363 ((B.TypeName _
| B.StructUnionName
(_
, _
) | B.EnumName _
|
3364 B.StructUnion
(_
, _
, _
) |
3365 B.FunctionType _
| B.Array
(_
, _
) | B.Pointer _
|
3371 (* todo: iso on sign, if not mentioned then free. tochange?
3372 * but that require to know if signed int because explicit
3373 * signed int, or because implicit signed int.
3376 and sign signa signb
=
3377 match signa
, signb
with
3378 | None
, None
-> return (None
, [])
3379 | Some signa
, Some
(signb
, ib
) ->
3380 if equal_sign (term signa
) signb
3381 then tokenf signa ib
>>= (fun signa ib
->
3382 return (Some signa
, [ib
])
3388 and minusize_list iixs
=
3389 iixs
+> List.fold_left
(fun acc ii
->
3390 acc
>>= (fun xs ys
->
3391 tokenf minusizer ii
>>= (fun minus ii
->
3392 return (minus
::xs
, ii
::ys
)
3393 ))) (return ([],[]))
3394 >>= (fun _xsminys ys
->
3395 return ((), List.rev ys
)
3398 and storage_optional_allminus
allminus stoa
(stob, iistob
) =
3399 (* "iso-by-absence" for storage, and return type. *)
3400 X.optional_storage_flag
(fun optional_storage
->
3401 match stoa
, stob with
3402 | None
, (stobis
, inline
) ->
3406 minusize_list iistob
>>= (fun () iistob
->
3407 return (None
, (stob, iistob
))
3409 else return (None
, (stob, iistob
))
3412 (match optional_storage
, stobis
with
3413 | false, B.NoSto
-> do_minus ()
3415 | true, B.NoSto
-> do_minus ()
3418 then pr2_once
"USING optional_storage builtin isomorphism";
3422 | Some x
, ((stobis
, inline
)) ->
3423 if equal_storage (term x
) stobis
3425 let rec loop acc
= function
3428 let str = B.str_of_info i1
in
3430 "static" | "extern" | "auto" | "register" ->
3431 (* not very elegant, but tokenf doesn't know what token to
3433 tokenf x i1
>>= (fun x i1
->
3434 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3435 return (Some x
, ((stobis
, inline
), rebuilt)))
3436 | _
-> loop (i1
::acc
) iistob
) in
3441 and inline_optional_allminus
allminus inla
(stob, iistob
) =
3442 (* "iso-by-absence" for storage, and return type. *)
3443 X.optional_storage_flag
(fun optional_storage
->
3444 match inla
, stob with
3445 | None
, (stobis
, inline
) ->
3449 minusize_list iistob
>>= (fun () iistob
->
3450 return (None
, (stob, iistob
))
3452 else return (None
, (stob, iistob
))
3461 then pr2_once
"USING optional_storage builtin isomorphism";
3464 else fail (* inline not in SP and present in C code *)
3467 | Some x
, ((stobis
, inline
)) ->
3470 let rec loop acc
= function
3473 let str = B.str_of_info i1
in
3476 (* not very elegant, but tokenf doesn't know what token to
3478 tokenf x i1
>>= (fun x i1
->
3479 let rebuilt = (List.rev acc
) @ i1
:: iistob
in
3480 return (Some x
, ((stobis
, inline
), rebuilt)))
3481 | _
-> loop (i1
::acc
) iistob
) in
3483 else fail (* SP has inline, but the C code does not *)
3486 and fullType_optional_allminus
allminus tya retb
=
3491 X.distrf_type
minusizer retb
>>= (fun _x retb
->
3495 else return (None
, retb
)
3497 fullType tya retb
>>= (fun tya retb
->
3498 return (Some tya
, retb
)
3503 (*---------------------------------------------------------------------------*)
3505 and compatible_base_type a signa b
=
3506 let ok = return ((),()) in
3509 | Type_cocci.VoidType
, B.Void
3510 | Type_cocci.SizeType
, B.SizeType
3511 | Type_cocci.SSizeType
, B.SSizeType
3512 | Type_cocci.PtrDiffType
, B.PtrDiffType
->
3513 assert (signa
=*= None
);
3515 | Type_cocci.CharType
, B.IntType
B.CChar
when signa
=*= None
->
3517 | Type_cocci.CharType
, B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3518 compatible_sign signa signb
3519 | Type_cocci.ShortType
, B.IntType
(B.Si
(signb
, B.CShort
)) ->
3520 compatible_sign signa signb
3521 | Type_cocci.IntType
, B.IntType
(B.Si
(signb
, B.CInt
)) ->
3522 compatible_sign signa signb
3523 | Type_cocci.LongType
, B.IntType
(B.Si
(signb
, B.CLong
)) ->
3524 compatible_sign signa signb
3525 | Type_cocci.LongLongType
, B.IntType
(B.Si
(signb
, B.CLongLong
)) ->
3526 compatible_sign signa signb
3527 | Type_cocci.FloatType
, B.FloatType
B.CFloat
->
3528 assert (signa
=*= None
);
3530 | Type_cocci.DoubleType
, B.FloatType
B.CDouble
->
3531 assert (signa
=*= None
);
3533 | _
, B.FloatType
B.CLongDouble
->
3534 pr2_once
"no longdouble in cocci";
3536 | Type_cocci.BoolType
, _
-> failwith
"no booltype in C"
3538 | _
, (B.Void
|B.FloatType _
|B.IntType _
3539 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3541 and compatible_base_type_meta a signa qua b ii
local =
3543 | Type_cocci.MetaType
(ida
,keep
,inherited
),
3544 B.IntType
(B.Si
(signb
, B.CChar2
)) ->
3545 compatible_sign signa signb
>>= fun _ _
->
3546 let newb = ((qua
, (B.BaseType
(B.IntType
B.CChar
),ii
)),local) in
3547 compatible_type a
newb
3548 | Type_cocci.MetaType
(ida
,keep
,inherited
), B.IntType
(B.Si
(signb
, ty)) ->
3549 compatible_sign signa signb
>>= fun _ _
->
3551 ((qua
, (B.BaseType
(B.IntType
(B.Si
(B.Signed
, ty))),ii
)),local) in
3552 compatible_type a
newb
3553 | _
, B.FloatType
B.CLongDouble
->
3554 pr2_once
"no longdouble in cocci";
3557 | _
, (B.Void
|B.FloatType _
|B.IntType _
3558 |B.SizeType
|B.SSizeType
|B.PtrDiffType
) -> fail
3561 and compatible_type a
(b
,local) =
3562 let ok = return ((),()) in
3564 let rec loop = function
3565 | _
, (qua
, (B.NoType
, _
)) ->
3566 failwith
"compatible_type: matching with NoType"
3567 | Type_cocci.BaseType a
, (qua
, (B.BaseType b
,ii
)) ->
3568 compatible_base_type a None b
3570 | Type_cocci.SignedT
(signa
,None
), (qua
, (B.BaseType b
,ii
)) ->
3571 compatible_base_type
Type_cocci.IntType
(Some signa
) b
3573 | Type_cocci.SignedT
(signa
,Some
ty), (qua
, (B.BaseType b
,ii
)) ->
3575 Type_cocci.BaseType
ty ->
3576 compatible_base_type
ty (Some signa
) b
3577 | Type_cocci.MetaType
(ida
,keep
,inherited
) ->
3578 compatible_base_type_meta
ty (Some signa
) qua b ii
local
3579 | _
-> failwith
"not possible")
3581 | Type_cocci.Pointer a
, (qub
, (B.Pointer b
, ii
)) ->
3583 | Type_cocci.FunctionPointer a
, _
->
3585 "TODO: function pointer type doesn't store enough information to determine compatibility"
3586 | Type_cocci.Array a
, (qub
, (B.Array
(eopt
, b
),ii
)) ->
3587 (* no size info for cocci *)
3589 | Type_cocci.StructUnionName
(sua
, name
),
3590 (qub
, (B.StructUnionName
(sub
, sb
),ii
)) ->
3591 if equal_structUnion_type_cocci sua sub
3592 then structure_type_name name sb ii
3594 | Type_cocci.EnumName
(name
),
3595 (qub
, (B.EnumName
(sb
),ii
)) -> structure_type_name name sb ii
3596 | Type_cocci.TypeName sa
, (qub
, (B.TypeName
(namesb
, _typb
),noii
)) ->
3597 let sb = Ast_c.str_of_name namesb
in
3602 | Type_cocci.ConstVol
(qua
, a
), (qub
, b
) ->
3603 if (fst qub
).B.const
&& (fst qub
).B.volatile
3606 pr2_once
("warning: the type is both const & volatile but cocci " ^
3607 "does not handle that");
3613 | Type_cocci.Const
-> (fst qub
).B.const
3614 | Type_cocci.Volatile
-> (fst qub
).B.volatile
3616 then loop (a
,(Ast_c.nQ
, b
))
3619 | Type_cocci.MetaType
(ida
,keep
,inherited
), typb
->
3621 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_type typb
) in
3622 X.envf keep inherited
(A.make_mcode ida
, B.MetaTypeVal typb
, max_min)
3626 (* subtil: must be after the MetaType case *)
3627 | a
, (qub
, (B.TypeName
(_namesb
, Some b
), noii
)) ->
3628 (* kind of typedef iso *)
3631 (* for metavariables of type expression *^* *)
3632 | Type_cocci.Unknown
, _
-> ok
3637 B.TypeOfType _
|B.TypeOfExpr _
|B.ParenType _
|
3638 B.EnumName _
|B.StructUnion
(_
, _
, _
)|B.Enum
(_
, _
)
3645 B.StructUnionName
(_
, _
)|
3647 B.Array
(_
, _
)|B.Pointer _
|B.TypeName _
|
3652 and structure_type_name nm
sb ii
=
3654 Type_cocci.NoName
-> ok
3655 | Type_cocci.Name sa
->
3659 | Type_cocci.MV
(ida
,keep
,inherited
) ->
3660 (* degenerate version of MetaId, no transformation possible *)
3661 let (ib1, ib2
) = tuple_of_list2 ii
in
3662 let max_min _
= Lib_parsing_c.lin_col_by_pos
[ib2
] in
3663 let mida = A.make_mcode ida
in
3664 X.envf keep inherited
(mida, B.MetaIdVal
(sb,[]), max_min)
3670 and compatible_sign signa signb
=
3671 let ok = return ((),()) in
3672 match signa
, signb
with
3674 | Some
Type_cocci.Signed
, B.Signed
3675 | Some
Type_cocci.Unsigned
, B.UnSigned
3680 and equal_structUnion_type_cocci a b
=
3682 | Type_cocci.Struct
, B.Struct
-> true
3683 | Type_cocci.Union
, B.Union
-> true
3684 | _
, (B.Struct
| B.Union
) -> false
3688 (*---------------------------------------------------------------------------*)
3689 and inc_file
(a
, before_after
) (b
, h_rel_pos
) =
3691 let rec aux_inc (ass
, bss
) passed
=
3695 let passed = List.rev
passed in
3697 (match before_after
, !h_rel_pos
with
3698 | IncludeNothing
, _
-> true
3699 | IncludeMcodeBefore
, Some x
->
3700 List.mem
passed (x
.Ast_c.first_of
)
3702 | IncludeMcodeAfter
, Some x
->
3703 List.mem
passed (x
.Ast_c.last_of
)
3705 (* no info, maybe cos of a #include <xx.h> that was already in a .h *)
3709 | (A.IncPath x
)::xs
, y
::ys
-> x
=$
= y
&& aux_inc (xs
, ys
) (x
::passed)
3710 | _
-> failwith
"IncDots not in last place or other pb"
3715 | A.Local ass
, B.Local bss
->
3716 aux_inc (ass
, bss
) []
3717 | A.NonLocal ass
, B.NonLocal bss
->
3718 aux_inc (ass
, bss
) []
3723 (*---------------------------------------------------------------------------*)
3725 and (define_params
: sequence
->
3726 (A.define_param list
, (string B.wrap
) B.wrap2 list
) matcher
) =
3727 fun seqstyle eas ebs
->
3729 | Unordered
-> failwith
"not handling ooo"
3731 define_paramsbis
eas (Ast_c.split_comma ebs
) >>= (fun eas ebs_splitted
->
3732 return (eas, (Ast_c.unsplit_comma ebs_splitted
))
3735 (* todo? facto code with argument and parameters ? *)
3736 and define_paramsbis
= fun eas ebs
->
3738 match A.unwrap ea
with
3739 A.DPdots
(mcode) -> Some
(mcode, None
)
3741 let build_dots (mcode, _optexpr
) = A.DPdots
(mcode) in
3742 let match_comma ea
=
3743 match A.unwrap ea
with
3744 A.DPComma ia1
-> Some ia1
3746 let build_comma ia1
= A.DPComma ia1
in
3747 let match_metalist ea
= None
in
3748 let build_metalist _
(ida
,leninfo
,keep
,inherited
) =
3749 failwith
"not possible" in
3750 let mktermval v = failwith
"not possible" in
3751 let special_cases ea
eas ebs
= None
in
3752 let no_ii x
= failwith
"not possible" in
3753 list_matcher match_dots build_dots match_comma build_comma
3754 match_metalist build_metalist mktermval
3755 special_cases define_parameter
X.distrf_define_params
no_ii
3756 (function x
-> x
) eas ebs
3758 and define_parameter
= fun parama paramb
->
3759 match A.unwrap parama
, paramb
with
3760 A.DParam ida
, (idb
, ii
) ->
3761 let ib1 = tuple_of_list1 ii
in
3762 ident DontKnow ida
(idb
, ib1) >>= (fun ida
(idb
, ib1) ->
3763 return ((A.DParam ida
)+> A.rewrap parama
,(idb
, [ib1])))
3764 | (A.OptDParam _
| A.UniqueDParam _
), _
->
3765 failwith
"handling Opt/Unique for define parameters"
3766 | A.DPcircles
(_
), ys
-> raise
(Impossible
48) (* in Ordered mode *)
3769 (*****************************************************************************)
3771 (*****************************************************************************)
3773 (* no global solution for positions here, because for a statement metavariable
3774 we want a MetaStmtVal, and for the others, it's not clear what we want *)
3776 let rec (rule_elem_node
: (A.rule_elem
, Control_flow_c.node
) matcher
) =
3779 x
>>= (fun a b
-> return (A.rewrap re a
, F.rewrap node b
))
3781 X.all_bound
(A.get_inherited re
) >&&>
3784 match A.unwrap re
, F.unwrap node
with
3786 (* note: the order of the clauses is important. *)
3788 | _
, F.Enter
| _
, F.Exit
| _
, F.ErrorExit
-> fail2()
3790 (* the metaRuleElem contains just '-' information. We dont need to add
3791 * stuff in the environment. If we need stuff in environment, because
3792 * there is a + S somewhere, then this will be done via MetaStmt, not
3794 * Can match TrueNode/FalseNode/... so must be placed before those cases.
3797 | A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
->
3798 let default = A.MetaRuleElem
(mcode,keep
,inherited
), unwrap_node
in
3799 (match unwrap_node
with
3801 | F.TrueNode
| F.FalseNode
| F.AfterNode
3802 | F.LoopFallThroughNode
| F.FallThroughNode
3804 if X.mode
=*= PatternMode
3807 if mcode_contain_plus (mcodekind mcode)
3808 then failwith
"try add stuff on fake node"
3809 (* minusize or contextize a fake node is ok *)
3812 | F.EndStatement None
->
3813 if X.mode
=*= PatternMode
then return default
3815 (* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
3816 if mcode_contain_plus (mcodekind mcode)
3818 let fake_info = Ast_c.fakeInfo() in
3819 distrf distrf_node (mcodekind mcode)
3820 (F.EndStatement (Some fake_info))
3821 else return unwrap_node
3825 | F.EndStatement
(Some i1
) ->
3826 tokenf mcode i1
>>= (fun mcode i1
->
3828 A.MetaRuleElem
(mcode,keep
, inherited
),
3829 F.EndStatement
(Some i1
)
3833 if X.mode
=*= PatternMode
then return default
3834 else failwith
"a MetaRuleElem can't transform a headfunc"
3836 if X.mode
=*= PatternMode
then return default
3838 X.distrf_node
(generalize_mcode mcode) node
>>= (fun mcode node
->
3840 A.MetaRuleElem
(mcode,keep
, inherited
),
3846 (* rene cant have found that a state containing a fake/exit/... should be
3848 * TODO: and F.Fake ?
3850 | _
, F.EndStatement _
| _
, F.CaseNode _
3851 | _
, F.TrueNode
| _
, F.FalseNode
| _
, F.AfterNode
3852 | _
, F.FallThroughNode
| _
, F.LoopFallThroughNode
3853 | _
, F.InLoopNode
-> fail2()
3855 (* really ? diff between pattern.ml and transformation.ml *)
3856 | _
, F.Fake
-> fail2()
3859 (* cas general: a Meta can match everything. It matches only
3860 * "header"-statement. We transform only MetaRuleElem, not MetaStmt.
3861 * So can't have been called in transform.
3863 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), F.Decl
(_
) -> fail
3865 | A.MetaStmt
(ida
,keep
,metainfoMaybeTodo
,inherited
), unwrap_node
->
3866 (* todo: should not happen in transform mode *)
3868 (match Control_flow_c.extract_fullstatement node
with
3871 Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_stmt stb
) in
3872 X.envf keep inherited
(ida
, Ast_c.MetaStmtVal stb
, max_min)
3874 (* no need tag ida, we can't be called in transform-mode *)
3876 A.MetaStmt
(ida
, keep
, metainfoMaybeTodo
, inherited
),
3884 | A.MetaStmtList _
, _
->
3885 failwith
"not handling MetaStmtList"
3887 | A.TopExp ea
, F.DefineExpr eb
->
3888 expression ea eb
>>= (fun ea eb
->
3894 | A.TopExp ea
, F.DefineType eb
->
3895 (match A.unwrap ea
with
3897 fullType ft eb
>>= (fun ft eb
->
3899 A.TopExp
(A.rewrap ea
(A.TypeExp
(ft
))),
3906 (* It is important to put this case before the one that fails because
3907 * of the lack of the counter part of a C construct in SmPL (for instance
3908 * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
3909 * yet certain constructs, those constructs may contain expression
3910 * that we still want and can transform.
3913 | A.Exp exp
, nodeb
->
3915 (* kind of iso, initialisation vs affectation *)
3917 match A.unwrap exp
, nodeb
with
3918 | A.Assignment
(ea
, op
, eb
, true), F.Decl decl
->
3919 initialisation_to_affectation decl
+> F.rewrap node
3924 (* Now keep fullstatement inside the control flow node,
3925 * so that can then get in a MetaStmtVar the fullstatement to later
3926 * pp back when the S is in a +. But that means that
3927 * Exp will match an Ifnode even if there is no such exp
3928 * inside the condition of the Ifnode (because the exp may
3929 * be deeper, in the then branch). So have to not visit
3930 * all inside a node anymore.
3932 * update: j'ai choisi d'accrocher au noeud du CFG Ã la
3933 * fois le fullstatement et le partialstatement et appeler le
3934 * visiteur que sur le partialstatement.
3937 match Ast_cocci.get_pos re
with
3938 | None
-> expression
3942 Lib_parsing_c.max_min_by_pos
(Lib_parsing_c.ii_of_expr eb
) in
3943 let keep = Type_cocci.Unitary
in
3944 let inherited = false in
3945 let max_min _
= failwith
"no pos" in
3946 X.envf
keep inherited (pos
, B.MetaPosVal
(min
,max
), max_min)
3952 X.cocciExp
expfn exp
node >>= (fun exp
node ->
3960 X.cocciTy fullType
ty node >>= (fun ty node ->
3967 | A.TopInit init
, nodeb
->
3968 X.cocciInit initialiser init
node >>= (fun init
node ->
3976 | A.FunHeader
(mckstart
, allminus, fninfoa
, ida
, oparen
, paramsa, cparen
),
3977 F.FunHeader
({B.f_name
= nameidb
;
3978 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
3982 f_old_c_style
= oldstyle
;
3987 then pr2 "OLD STYLE DECL NOT WELL SUPPORTED";
3990 (* fninfoa records the order in which the SP specified the various
3991 information, but this isn't taken into account in the matching.
3992 Could this be a problem for transformation? *)
3995 List.filter
(function A.FStorage
(s) -> true | _
-> false) fninfoa
3996 with [A.FStorage
(s)] -> Some
s | _
-> None
in
3998 match List.filter
(function A.FType
(s) -> true | _
-> false) fninfoa
3999 with [A.FType
(t
)] -> Some t
| _
-> None
in
4002 match List.filter
(function A.FInline
(i
) -> true | _
-> false) fninfoa
4003 with [A.FInline
(i
)] -> Some i
| _
-> None
in
4005 (match List.filter
(function A.FAttr
(a
) -> true | _
-> false) fninfoa
4006 with [A.FAttr
(a
)] -> failwith
"not checking attributes" | _
-> ());
4009 | ioparenb
::icparenb
::iifakestart
::iistob
->
4011 (* maybe important to put ident as the first tokens to transform.
4012 * It's related to transform_proto. So don't change order
4015 ident_cpp LocalFunction ida nameidb
>>= (fun ida nameidb
->
4016 X.tokenf_mck mckstart iifakestart
>>= (fun mckstart iifakestart
->
4017 tokenf oparen ioparenb
>>= (fun oparen ioparenb
->
4018 tokenf cparen icparenb
>>= (fun cparen icparenb
->
4019 parameters
(seqstyle paramsa)
4020 (A.undots
paramsa) paramsb
>>=
4021 (fun paramsaundots paramsb
->
4022 let paramsa = redots
paramsa paramsaundots
in
4023 inline_optional_allminus
allminus
4024 inla (stob, iistob
) >>= (fun inla (stob, iistob
) ->
4025 storage_optional_allminus
allminus
4026 stoa (stob, iistob
) >>= (fun stoa (stob, iistob
) ->
4031 ("Not handling well variable length arguments func. "^
4032 "You have been warned");
4034 then minusize_list iidotsb
4035 else return ((),iidotsb
)
4036 ) >>= (fun () iidotsb
->
4038 fullType_optional_allminus
allminus tya retb
>>= (fun tya retb
->
4041 (match stoa with Some st
-> [A.FStorage st
] | None
-> []) ++
4042 (match inla with Some i
-> [A.FInline i
] | None
-> []) ++
4043 (match tya with Some t
-> [A.FType t
] | None
-> [])
4048 A.FunHeader
(mckstart
,allminus,fninfoa,ida
,oparen
,
4050 F.FunHeader
({B.f_name
= nameidb
;
4051 f_type
= (retb
, (paramsb
, (isvaargs
, iidotsb
)));
4055 f_old_c_style
= oldstyle
; (* TODO *)
4057 ioparenb
::icparenb
::iifakestart
::iistob
)
4060 | _
-> raise
(Impossible
49)
4063 | A.Decl
(mckstart
,allminus,decla
), F.Decl declb
->
4064 declaration
(mckstart
,allminus,decla
) declb
>>=
4065 (fun (mckstart
,allminus,decla
) declb
->
4067 A.Decl
(mckstart
,allminus,decla
),
4072 | A.SeqStart
mcode, F.SeqStart
(st
, level
, i1
) ->
4073 tokenf mcode i1
>>= (fun mcode i1
->
4076 F.SeqStart
(st
, level
, i1
)
4079 | A.SeqEnd
mcode, F.SeqEnd
(level
, i1
) ->
4080 tokenf mcode i1
>>= (fun mcode i1
->
4083 F.SeqEnd
(level
, i1
)
4086 | A.ExprStatement
(Some ea
, ia1
), F.ExprStatement
(st
, (Some eb
, ii
)) ->
4087 let ib1 = tuple_of_list1 ii
in
4088 expression ea eb
>>= (fun ea eb
->
4089 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4091 A.ExprStatement
(Some ea
, ia1
),
4092 F.ExprStatement
(st
, (Some eb
, [ib1]))
4096 | A.ExprStatement
(None
, ia1
), F.ExprStatement
(st
, (None
, ii
)) ->
4097 let ib1 = tuple_of_list1 ii
in
4098 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4100 A.ExprStatement
(None
, ia1
),
4101 F.ExprStatement
(st
, (None
, [ib1]))
4106 | A.IfHeader
(ia1
,ia2
, ea
, ia3
), F.IfHeader
(st
, (eb
,ii
)) ->
4107 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4108 expression ea eb
>>= (fun ea eb
->
4109 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4110 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4111 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4113 A.IfHeader
(ia1
, ia2
, ea
, ia3
),
4114 F.IfHeader
(st
, (eb
,[ib1;ib2
;ib3
]))
4117 | A.Else ia
, F.Else ib
->
4118 tokenf ia ib
>>= (fun ia ib
->
4119 return (A.Else ia
, F.Else ib
)
4122 | A.WhileHeader
(ia1
, ia2
, ea
, ia3
), F.WhileHeader
(st
, (eb
, ii
)) ->
4123 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4124 expression ea eb
>>= (fun ea eb
->
4125 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4126 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4127 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4129 A.WhileHeader
(ia1
, ia2
, ea
, ia3
),
4130 F.WhileHeader
(st
, (eb
, [ib1;ib2
;ib3
]))
4133 | A.DoHeader ia
, F.DoHeader
(st
, ib
) ->
4134 tokenf ia ib
>>= (fun ia ib
->
4139 | A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
), F.DoWhileTail
(eb
, ii
) ->
4140 let (ib1, ib2
, ib3
, ib4
) = tuple_of_list4 ii
in
4141 expression ea eb
>>= (fun ea eb
->
4142 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4143 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4144 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4145 tokenf ia4 ib4
>>= (fun ia4 ib4
->
4147 A.WhileTail
(ia1
,ia2
,ea
,ia3
,ia4
),
4148 F.DoWhileTail
(eb
, [ib1;ib2
;ib3
;ib4
])
4150 | A.IteratorHeader
(ia1
, ia2
, eas, ia3
), F.MacroIterHeader
(st
, ((s,ebs
),ii
))
4152 let (ib1, ib2
, ib3
) = tuple_of_list3 ii
in
4154 ident DontKnow ia1
(s, ib1) >>= (fun ia1
(s, ib1) ->
4155 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4156 tokenf ia3 ib3
>>= (fun ia3 ib3
->
4157 arguments
(seqstyle eas) (A.undots
eas) ebs
>>= (fun easundots ebs
->
4158 let eas = redots
eas easundots
in
4160 A.IteratorHeader
(ia1
, ia2
, eas, ia3
),
4161 F.MacroIterHeader
(st
, ((s,ebs
), [ib1;ib2
;ib3
]))
4166 | A.ForHeader
(ia1
, ia2
, firsta
, ea2opt
, ia4
, ea3opt
, ia5
),
4167 F.ForHeader
(st
, ((firstb
, (eb2opt
,ib4s
), (eb3opt
,ib4vide
)), ii
))
4169 assert (null ib4vide
);
4170 let (ib1, ib2
, ib5
) = tuple_of_list3 ii
in
4171 let ib4 = tuple_of_list1 ib4s
in
4173 (match (firsta
,firstb
) with
4174 (A.ForExp
(ea1opt
, ia3
),B.ForExp
(eb1opt
,ib3s
)) ->
4175 let ib3 = tuple_of_list1 ib3s
in
4176 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
4177 option expression ea1opt eb1opt
>>= (fun ea1opt eb1opt
->
4178 return (A.ForExp
(ea1opt
, ia3
),B.ForExp
(eb1opt
,[ib3]))))
4179 | (A.ForDecl
(mckstart
,allminus,decla
),B.ForDecl declb
) ->
4180 declaration
(mckstart
,allminus,decla
) declb
>>=
4181 (fun (mckstart
,allminus,decla
) declb
->
4183 A.ForDecl
(mckstart
,allminus,decla
),
4188 (fun firsta firstb
->
4189 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4190 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4191 tokenf ia4
ib4 >>= (fun ia4
ib4 ->
4192 tokenf ia5 ib5
>>= (fun ia5 ib5
->
4193 option expression ea2opt eb2opt
>>= (fun ea2opt eb2opt
->
4194 option expression ea3opt eb3opt
>>= (fun ea3opt eb3opt
->
4196 A.ForHeader
(ia1
, ia2
, firsta
, ea2opt
, ia4
, ea3opt
, ia5
),
4197 F.ForHeader
(st
,((firstb
,(eb2opt
,[ib4]),(eb3opt
,[])),[ib1;ib2
;ib5
]))
4201 | A.SwitchHeader
(ia1
,ia2
,ea
,ia3
), F.SwitchHeader
(st
, (eb
,ii
)) ->
4202 let (ib1, ib2
, ib3) = tuple_of_list3 ii
in
4203 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4204 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4205 tokenf ia3
ib3 >>= (fun ia3
ib3 ->
4206 expression ea eb
>>= (fun ea eb
->
4208 A.SwitchHeader
(ia1
,ia2
,ea
,ia3
),
4209 F.SwitchHeader
(st
, (eb
,[ib1;ib2
;ib3]))
4212 | A.Break
(ia1
, ia2
), F.Break
(st
, ((),ii
)) ->
4213 let (ib1, ib2
) = tuple_of_list2 ii
in
4214 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4215 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4218 F.Break
(st
, ((),[ib1;ib2
]))
4221 | A.Continue
(ia1
, ia2
), F.Continue
(st
, ((),ii
)) ->
4222 let (ib1, ib2
) = tuple_of_list2 ii
in
4223 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4224 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4226 A.Continue
(ia1
, ia2
),
4227 F.Continue
(st
, ((),[ib1;ib2
]))
4230 | A.Return
(ia1
, ia2
), F.Return
(st
, ((),ii
)) ->
4231 let (ib1, ib2
) = tuple_of_list2 ii
in
4232 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4233 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4235 A.Return
(ia1
, ia2
),
4236 F.Return
(st
, ((),[ib1;ib2
]))
4239 | A.ReturnExpr
(ia1
, ea
, ia2
), F.ReturnExpr
(st
, (eb
, ii
)) ->
4240 let (ib1, ib2
) = tuple_of_list2 ii
in
4241 tokenf ia1
ib1 >>= (fun ia1
ib1 ->
4242 tokenf ia2 ib2
>>= (fun ia2 ib2
->
4243 expression ea eb
>>= (fun ea eb
->
4245 A.ReturnExpr
(ia1
, ea
, ia2
),
4246 F.ReturnExpr
(st
, (eb
, [ib1;ib2
]))
4251 | A.Include
(incla
,filea
),
4252 F.Include
{B.i_include
= (fileb
, ii
);
4253 B.i_rel_pos
= h_rel_pos
;
4254 B.i_is_in_ifdef
= inifdef
;
4257 assert (copt
=*= None
);
4259 let include_requirment =
4260 match mcodekind incla
, mcodekind filea
with
4261 | A.CONTEXT
(_
, A.BEFORE _
), _
->
4263 | _
, A.CONTEXT
(_
, A.AFTER _
) ->
4269 let (inclb
, iifileb
) = tuple_of_list2 ii
in
4270 if inc_file
(term filea
, include_requirment) (fileb
, h_rel_pos
)
4272 tokenf incla inclb
>>= (fun incla inclb
->
4273 tokenf filea iifileb
>>= (fun filea iifileb
->
4275 A.Include
(incla
, filea
),
4276 F.Include
{B.i_include
= (fileb
, [inclb
;iifileb
]);
4277 B.i_rel_pos
= h_rel_pos
;
4278 B.i_is_in_ifdef
= inifdef
;
4284 | A.Undef
(undefa
,ida
), F.DefineHeader
((idb
, ii
), B.Undef
) ->
4285 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4286 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4287 tokenf undefa defineb
>>= (fun undefa defineb
->
4289 A.Undef
(undefa
,ida
),
4290 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),B.Undef
)
4295 | A.DefineHeader
(definea
,ida
,params
), F.DefineHeader
((idb
, ii
), defkind
) ->
4296 let (defineb
, iidb
, ieol
) = tuple_of_list3 ii
in
4297 ident DontKnow ida
(idb
, iidb
) >>= (fun ida
(idb
, iidb
) ->
4298 tokenf definea defineb
>>= (fun definea defineb
->
4299 (match A.unwrap params
, defkind
with
4300 | A.NoParams
, B.DefineVar
->
4302 A.NoParams
+> A.rewrap params
,
4305 | A.DParams
(lpa
,eas,rpa
), (B.DefineFunc
(ebs
, ii
)) ->
4306 let (lpb
, rpb
) = tuple_of_list2 ii
in
4307 tokenf lpa lpb
>>= (fun lpa lpb
->
4308 tokenf rpa rpb
>>= (fun rpa rpb
->
4310 define_params
(seqstyle eas) (A.undots
eas) ebs
>>=
4311 (fun easundots ebs
->
4312 let eas = redots
eas easundots
in
4314 A.DParams
(lpa
,eas,rpa
) +> A.rewrap params
,
4315 B.DefineFunc
(ebs
,[lpb
;rpb
])
4319 ) >>= (fun params defkind
->
4321 A.DefineHeader
(definea
, ida
, params
),
4322 F.DefineHeader
((idb
,[defineb
;iidb
;ieol
]),defkind
)
4327 | A.Default
(def
,colon
), F.Default
(st
, ((),ii
)) ->
4328 let (ib1, ib2
) = tuple_of_list2 ii
in
4329 tokenf def
ib1 >>= (fun def
ib1 ->
4330 tokenf colon ib2
>>= (fun colon ib2
->
4332 A.Default
(def
,colon
),
4333 F.Default
(st
, ((),[ib1;ib2
]))
4338 | A.Case
(case
,ea
,colon
), F.Case
(st
, (eb
,ii
)) ->
4339 let (ib1, ib2
) = tuple_of_list2 ii
in
4340 tokenf case
ib1 >>= (fun case
ib1 ->
4341 expression ea eb
>>= (fun ea eb
->
4342 tokenf colon ib2
>>= (fun colon ib2
->
4344 A.Case
(case
,ea
,colon
),
4345 F.Case
(st
, (eb
,[ib1;ib2
]))
4348 (* only occurs in the predicates generated by asttomember *)
4349 | A.DisjRuleElem
eas, _
->
4351 List.fold_left
(fun acc ea
-> acc
>|+|> (rule_elem_node ea
node)) fail)
4352 >>= (fun ea eb
-> return (A.unwrap ea
,F.unwrap eb
))
4354 | _
, F.ExprStatement
(_
, (None
, ii
)) -> fail (* happen ? *)
4356 | A.Label
(id
,dd
), F.Label
(st
, nameb
, ((),ii
)) ->
4357 let (ib2
) = tuple_of_list1 ii
in
4358 ident_cpp DontKnow id nameb
>>= (fun ida nameb
->
4359 tokenf dd ib2
>>= (fun dd ib2
->
4362 F.Label
(st
,nameb
, ((),[ib2
]))
4365 | A.Goto
(goto
,id
,sem
), F.Goto
(st
,nameb
, ((),ii
)) ->
4366 let (ib1,ib3) = tuple_of_list2 ii
in
4367 tokenf goto
ib1 >>= (fun goto
ib1 ->
4368 ident_cpp DontKnow id nameb
>>= (fun id nameb
->
4369 tokenf sem
ib3 >>= (fun sem
ib3 ->
4371 A.Goto
(goto
,id
,sem
),
4372 F.Goto
(st
,nameb
, ((),[ib1;ib3]))
4375 (* have not a counter part in coccinelle, for the moment *)
4376 (* todo?: print a warning at least ? *)
4383 | _
, (F.IfdefEndif _
|F.IfdefElse _
|F.IfdefHeader _
)
4387 (F.MacroStmt
(_
, _
)| F.DefineDoWhileZeroHeader _
| F.EndNode
|F.TopNode
)
4390 (F.Label
(_
, _
, _
)|F.Break
(_
, _
)|F.Continue
(_
, _
)|F.Default
(_
, _
)|
4391 F.Case
(_
, _
)|F.Include _
|F.Goto _
|F.ExprStatement _
|
4392 F.DefineType _
|F.DefineExpr _
|F.DefineTodo
|
4393 F.DefineHeader
(_
, _
)|F.ReturnExpr
(_
, _
)|F.Return
(_
, _
)|
4394 F.MacroIterHeader
(_
, _
)|
4395 F.SwitchHeader
(_
, _
)|F.ForHeader
(_
, _
)|F.DoWhileTail _
|F.DoHeader
(_
, _
)|
4396 F.WhileHeader
(_
, _
)|F.Else _
|F.IfHeader
(_
, _
)|
4397 F.SeqEnd
(_
, _
)|F.SeqStart
(_
, _
, _
)|
4398 F.Decl _
|F.FunHeader _
)