*)
-(* Yoann Padioleau, Julia Lawall
- *
- * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License (GPL)
- * version 2 as published by the Free Software Foundation.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * file license.txt for more details.
- *
- * This file was part of Coccinelle.
- *)
-
open Common
module A = Ast_cocci
(*****************************************************************************)
let pr2, pr2_once = Common.mk_pr2_wrappers Flag_matcher.verbose_matcher
+let (+++) a b = match a with Some x -> Some x | None -> b
+
+let error ii str =
+ match ii with
+ [] -> failwith str
+ | ii::_ ->
+ failwith
+ (Printf.sprintf "%s: %d: %s"
+ (Ast_c.file_of_info ii) (Ast_c.line_of_info ii) str)
+
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
(* For the #include <linux/...> in the .cocci, need to find where is
* the '+' attached to this element, to later find the first concrete
- * #include <linux/xxx.h> or last one in the serie of #includes in the
+ * #include <linux/xxx.h> or last one in the series of #includes in the
* .c.
*)
type include_requirement =
| Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
+ | Ast_c.MetaDeclVal a, Ast_c.MetaDeclVal b ->
+ Lib_parsing_c.al_declaration a =*= Lib_parsing_c.al_declaration b
+ | Ast_c.MetaFieldVal a, Ast_c.MetaFieldVal b ->
+ Lib_parsing_c.al_field a =*= Lib_parsing_c.al_field b
+ | Ast_c.MetaFieldListVal a, Ast_c.MetaFieldListVal b ->
+ Lib_parsing_c.al_fields a =*= Lib_parsing_c.al_fields b
| Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
| Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
l1
| (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
+ |B.MetaDeclVal _ |B.MetaFieldVal _ |B.MetaFieldListVal _
|B.MetaTypeVal _ |B.MetaInitVal _
|B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
|B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
| Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
Lib_parsing_c.al_inh_arguments a =*= Lib_parsing_c.al_inh_arguments b
+ | Ast_c.MetaDeclVal a, Ast_c.MetaDeclVal b ->
+ Lib_parsing_c.al_inh_declaration a =*= Lib_parsing_c.al_inh_declaration b
+ | Ast_c.MetaFieldVal a, Ast_c.MetaFieldVal b ->
+ Lib_parsing_c.al_inh_field a =*= Lib_parsing_c.al_inh_field b
+ | Ast_c.MetaFieldListVal a, Ast_c.MetaFieldListVal b ->
+ Lib_parsing_c.al_inh_field_list a =*= Lib_parsing_c.al_inh_field_list b
| Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
Lib_parsing_c.al_inh_statement a =*= Lib_parsing_c.al_inh_statement b
| Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
l1
| (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
+ |B.MetaDeclVal _ |B.MetaFieldVal _ |B.MetaFieldListVal _
|B.MetaTypeVal _ |B.MetaInitVal _
|B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
|B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
| B.CInt, ["",i1] -> (* no type is specified at all *)
(match i1.B.pinfo with
B.FakeTok(_,_) -> []
- | _ -> failwith ("unrecognized signed int: "^
- (String.concat " "(List.map fst iis))))
+ | _ -> error [i1] ("unrecognized signed int: "^
+ (String.concat " "(List.map fst iis))))
| B.CChar2, ["char",i2] -> [i2]
| B.CLongLong, ["long",i1;"long",i2;"int",i3] -> [i1;i2;i3]
| _ ->
- failwith ("strange type1, maybe because of weird order: "^
- (String.concat " " (List.map fst iis))) in
+ error (List.map snd iis)
+ ("strange type1, maybe because of weird order: "^
+ (String.concat " " (List.map fst iis))) in
(signed,base_res)
- | _ -> failwith ("strange type2, maybe because of weird order: "^
- (String.concat " " (List.map fst iis)))
+
+ | B.SizeType, ["size_t",i1] -> None, [i1]
+ | B.SSizeType, ["ssize_t",i1] -> None, [i1]
+ | B.PtrDiffType, ["ptrdiff_t",i1] -> None, [i1]
+
+ | _ ->
+ error (List.map snd iis)
+ ("strange type2, maybe because of weird order: "^
+ (String.concat " " (List.map fst iis)))
(*---------------------------------------------------------------------------*)
| [], [] -> []
| [], _ ->
failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
- failwith "shouldn't have a iicomma"
+ | iicommas, [] ->
+ error iicommas "shouldn't have a iicomma"
| [iicomma], x::xs ->
let elems = List.map fst (x::xs) in
let commas = List.map snd (x::xs) +> List.flatten in
| _ -> raise Impossible
(*---------------------------------------------------------------------------*)
+let one_initialisation_to_affectation x =
+ let ({B.v_namei = var;
+ B.v_type = returnType;
+ B.v_type_bis = tybis;
+ B.v_storage = storage;
+ B.v_local = local},
+ iisep) = x in
+ match var with
+ | Some (name, iniopt) ->
+ (match iniopt with
+ | B.ValInit (iini, (B.InitExpr e, ii_empty2)) ->
+ let local =
+ match local with
+ Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
+ | Ast_c.LocalDecl ->
+ Ast_c.LocalVar (Ast_c.info_of_type returnType) in
+ let typexp =
+ (* old: Lib_parsing_c.al_type returnType
+ * but this type has not the typename completed so
+ * instead try to use tybis
+ *)
+ match !tybis with
+ | Some ty_with_typename_completed -> ty_with_typename_completed
+ | None -> raise Impossible
+ in
+
+ let typ = ref (Some (typexp,local), Ast_c.NotTest) in
+ let ident = name in
+ let idexpr = Ast_c.mk_e_bis (B.Ident ident) typ Ast_c.noii in
+ let assign =
+ Ast_c.mk_e (B.Assignment (idexpr,B.SimpleAssign, e)) [iini] in
+ Some assign
+ | _ -> None)
+ | _ -> None
+
let initialisation_to_affectation decl =
match decl with
| B.MacroDecl _ -> F.Decl decl
(* todo?: should not do that if the variable is an array cos
* will have x[] = , mais de toute facon ca sera pas un InitExp
*)
- (match xs with
- | [] -> raise Impossible
- | [x] ->
- let ({B.v_namei = var;
- B.v_type = returnType;
- B.v_type_bis = tybis;
- B.v_storage = storage;
- B.v_local = local},
- iisep) = x in
-
-
-
- (match var with
- | Some (name, iniopt) ->
- (match iniopt with
- | Some (iini, (B.InitExpr e, ii_empty2)) ->
-
- let local =
- match local with
- Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl ->
- Ast_c.LocalVar (Ast_c.info_of_type returnType) in
-
- let typexp =
- (* old: Lib_parsing_c.al_type returnType
- * but this type has not the typename completed so
- * instead try to use tybis
- *)
- match !tybis with
- | Some ty_with_typename_completed ->
- ty_with_typename_completed
- | None -> raise Impossible
- in
-
- let typ =
- ref (Some (typexp,local),
- Ast_c.NotTest) in
- let ident = name in
- let idexpr =
- Ast_c.mk_e_bis (B.Ident (ident)) typ Ast_c.noii
- in
- let assign =
- Ast_c.mk_e
- (B.Assignment (idexpr,B.SimpleAssign, e)) [iini] in
- F.DefineExpr assign
-
- | _ -> F.Decl decl
- )
- | _ -> F.Decl decl
- )
- | x::xs ->
- pr2_once "TODO: initialisation_to_affectation for multi vars";
- (* todo? do a fold_left and generate 'x = a, y = b' etc, use
- * the Sequence expression operator of C and make an
- * ExprStatement from that.
- *)
- F.Decl decl
- )
-
-
-
-
+ let possible_assignment =
+ List.fold_left
+ (function prev ->
+ function x ->
+ match prev,one_initialisation_to_affectation x with
+ _,None -> prev
+ | None,Some x -> Some x
+ | Some prev,Some x ->
+ (* [] is clearly an invalid ii value for a sequence.
+ hope that no one looks at it, since nothing will
+ match the sequence. Fortunately, SmPL doesn't
+ support , expressions. *)
+ Some (Ast_c.mk_e (Ast_c.Sequence (prev, x)) []))
+ None xs in
+ match possible_assignment with
+ Some x -> F.DefineExpr x
+ | None -> F.Decl decl
(*****************************************************************************)
(* Functor parameter combinators *)
(A.meta_name A.mcode, Ast_c.parameterType) matcher
val distrf_ini :
(A.meta_name A.mcode, Ast_c.initialiser) matcher
+ val distrf_inis :
+ (A.meta_name A.mcode, (Ast_c.initialiser, Ast_c.il) either list) matcher
+ val distrf_decl :
+ (A.meta_name A.mcode, Ast_c.declaration) matcher
+ val distrf_field :
+ (A.meta_name A.mcode, Ast_c.field) matcher
val distrf_node :
(A.meta_name A.mcode, Control_flow_c.node) matcher
val distrf_define_params :
- (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
- matcher
+ (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list) matcher
+
+ val distrf_enum_fields :
+ (A.meta_name A.mcode, (B.oneEnumType, B.il) either list) matcher
val distrf_struct_fields :
(A.meta_name A.mcode, B.field list) matcher
val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
end
(*****************************************************************************)
| Ast_c.Float (float, _) -> satisfies_regexpconstraint c float)
| _ -> warning "Unable to apply a constraint on an expression!"
+
+(* ------------------------------------------------------------------------- *)
+(* This has to be up here to allow adequate polymorphism *)
+
+let list_matcher match_dots rebuild_dots match_comma rebuild_comma
+ match_metalist rebuild_metalist mktermval special_cases
+ element distrf get_iis = fun eas ebs ->
+ let rec loop = function
+ [], [] -> return ([], [])
+ | [], eb::ebs -> fail
+ | ea::eas, ebs ->
+ X.all_bound (A.get_inherited ea) >&&>
+ let try_matches =
+ (match match_dots ea, ebs with
+ Some (mcode, optexpr), ys ->
+ (* todo: if optexpr, then a WHEN and so may have to filter yys *)
+ if optexpr <> None then failwith "not handling when in a list";
+
+ (* '...' can take more or less the beginnings of the arguments *)
+ let startendxs =
+ Common.zip (Common.inits ys) (Common.tails ys) in
+ Some
+ (startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ acc >||> (
+
+ (* allow '...', and maybe its associated ',' to match nothing.
+ * for the associated ',' see below how we handle the EComma
+ * to match nothing.
+ *)
+ (if null startxs
+ then
+ if mcode_contain_plus (mcodekind mcode)
+ then fail
+ (*failwith
+ "I have no token that I could accroche myself on"*)
+ else return (dots2metavar mcode, [])
+ else
+ (* subtil: we dont want the '...' to match until the
+ * comma. cf -test pb_params_iso. We would get at
+ * "already tagged" error.
+ * this is because both f (... x, ...) and f (..., x, ...)
+ * would match a f(x,3) with our "optional-comma" strategy.
+ *)
+ (match Common.last startxs with
+ | Right _ -> fail
+ | Left _ -> distrf (dots2metavar mcode) startxs))
+
+ >>= (fun mcode startxs ->
+ let mcode = metavar2dots mcode in
+ loop (eas, endxs) >>= (fun eas endxs ->
+ return (
+ (rebuild_dots (mcode, optexpr) +> A.rewrap ea) ::eas,
+ startxs ++ endxs
+ )))
+ )
+ ) fail)
+
+ | None,_ -> None)
+ +++
+ (match match_comma ea, ebs with
+ | Some ia1, Right ii::ebs ->
+ Some
+ (let ib1 = tuple_of_list1 ii in
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ loop (eas, ebs) >>= (fun eas ebs ->
+ return (
+ (rebuild_comma ia1 +> A.rewrap ea)::eas,
+ (Right [ib1])::ebs
+ )
+ )))
+ | Some ia1, ebs ->
+ (* allow ',' to maching nothing. optional comma trick *)
+ Some
+ (if mcode_contain_plus (mcodekind ia1)
+ then fail
+ else loop (eas, ebs))
+ | None,_ -> None)
+ +++
+ (match match_metalist ea, ebs with
+ Some (ida,leninfo,keep,inherited), ys ->
+ let startendxs =
+ Common.zip (Common.inits ys) (Common.tails ys) in
+ Some
+ (startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ acc >||> (
+ let ok =
+ if null startxs
+ then
+ if mcode_contain_plus (mcodekind ida)
+ then false
+ (* failwith "no token that I could accroche myself on" *)
+ else true
+ else
+ (match Common.last startxs with
+ | Right _ -> false
+ | Left _ -> true)
+ in
+ if not ok
+ then fail
+ else
+ let startxs' = Ast_c.unsplit_comma startxs in
+ let len = List.length startxs' in
+
+ (match leninfo with
+ | A.MetaListLen (lenname,lenkeep,leninherited) ->
+ let max_min _ = failwith "no pos" in
+ X.envf lenkeep leninherited
+ (lenname, Ast_c.MetaListlenVal (len), max_min)
+ | A.CstListLen n ->
+ if len = n
+ then (function f -> f())
+ else (function f -> fail)
+ | A.AnyListLen -> function f -> f()
+ )
+ (fun () ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (get_iis startxs) in
+ X.envf keep inherited
+ (ida, mktermval startxs', max_min)
+ (fun () ->
+ if null startxs
+ then return (ida, [])
+ else distrf ida (Ast_c.split_comma startxs'))
+ >>= (fun ida startxs ->
+ loop (eas, endxs) >>= (fun eas endxs ->
+ return (
+ (rebuild_metalist(ida,leninfo,keep,inherited))
+ +> A.rewrap ea::eas,
+ startxs ++ endxs
+ ))
+ )
+ )
+ )) fail)
+ | None,_ -> None)
+ +++
+ special_cases ea eas ebs in
+ match try_matches with
+ Some res -> res
+ | None ->
+ (match ebs with
+ | (Left eb)::ebs ->
+ element ea eb >>= (fun ea eb ->
+ loop (eas, ebs) >>= (fun eas ebs ->
+ return (ea::eas, Left eb::ebs)))
+ | (Right y)::ys -> raise Impossible
+ | [] -> fail) in
+ loop (eas,ebs)
+
(*---------------------------------------------------------------------------*)
(* toc:
* - expression
expression ea2 eb2 >>= (fun ea2 eb2 ->
tokenf opa opbi >>= (fun opa opbi ->
return (
- ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
+ (A.Assignment (ea1, opa, ea2, simple)) +> wa,
((B.Assignment (eb1, opb, eb2), typ), [opbi])
))))
else fail
| _, ((B.Sequence _,_),_)
| _, ((B.StatementExpr _,_),_)
| _, ((B.Constructor _,_),_)
+ | _, ((B.New _,_),_)
+ | _, ((B.Delete _,_),_)
-> fail
fail
and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib)) -> (* (idb, iib) as ib *)
+ fun infoidb ida ((idb, iib) as ib) -> (* (idb, iib) as ib *)
let check_constraints constraints idb =
let meta_id_val l x = Ast_c.MetaIdVal(x,l) in
match constraints with
| DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
)
+ (* not clear why disj things are needed, after disjdistr? *)
+ | A.DisjId ias ->
+ ias +> List.fold_left (fun acc ia -> acc >|+|> (ident infoidb ia ib)) fail
+
| A.OptIdent _ | A.UniqueIdent _ ->
failwith "not handling Opt/Unique for ident"
-
-
-
+
(* ------------------------------------------------------------------------- *)
and (arguments: sequence ->
- (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | Ordered ->
- arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
+ (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
+ fun seqstyle eas ebs ->
+ match seqstyle with
+ | Unordered -> failwith "not handling ooo"
+ | Ordered ->
+ arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
+ return (eas, (Ast_c.unsplit_comma ebs_splitted))
+ )
(* because '...' can match nothing, need to take care when have
- * ', ...' or '...,' as in f(..., X, Y, ...). It must match
- * f(1,2) for instance.
- * So I have added special cases such as (if startxs = []) and code
- * in the Ecomma matching rule.
- *
- * old: Must do some try, for instance when f(...,X,Y,...) have to
- * test the transfo for all the combinaitions and if multiple transfo
- * possible ? pb ? => the type is to return a expression option ? use
- * some combinators to help ?
- * update: with the tag-SP approach, no more a problem.
- *)
-
+ * ', ...' or '...,' as in f(..., X, Y, ...). It must match
+ * f(1,2) for instance.
+ * So I have added special cases such as (if startxs = []) and code
+ * in the Ecomma matching rule.
+ *
+ * old: Must do some try, for instance when f(...,X,Y,...) have to
+ * test the transfo for all the combinaitions and if multiple transfo
+ * possible ? pb ? => the type is to return a expression option ? use
+ * some combinators to help ?
+ * update: with the tag-SP approach, no more a problem.
+*)
+
and arguments_bis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Edots (mcode, optexpr), ys ->
- (* todo: if optexpr, then a WHEN and so may have to filter yys *)
- if optexpr <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (* allow '...', and maybe its associated ',' to match nothing.
- * for the associated ',' see below how we handle the EComma
- * to match nothing.
- *)
- (if null startxs
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (* subtil: we dont want the '...' to match until the
- * comma. cf -test pb_params_iso. We would get at
- * "already tagged" error.
- * this is because both f (... x, ...) and f (..., x, ...)
- * would match a f(x,3) with our "optional-comma" strategy.
- *)
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_args (dots2metavar mcode) startxs
- )
- )
- >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.EComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.EComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
- | A.EComma ia1, ebs ->
- (* allow ',' to maching nothing. optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else arguments_bis eas ebs
-
- | A.MetaExprList(ida,leninfo,keep,inherited),ys ->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if null startxs
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_args startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaExprListVal startxs', max_min)
- (fun () ->
- if null startxs
- then return (ida, [])
- else X.distrf_args ida (Ast_c.split_comma startxs')
- )
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaExprList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- )
- )) fail
-
-
- | _unwrapx, (Left eb)::ebs ->
- argument ea eb >>= (fun ea eb ->
- arguments_bis eas ebs >>= (fun eas ebs ->
- return (ea::eas, Left eb::ebs)
- ))
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
+ let match_dots ea =
+ match A.unwrap ea with
+ A.Edots(mcode, optexpr) -> Some (mcode, optexpr)
+ | _ -> None in
+ let build_dots (mcode, optexpr) = A.Edots(mcode, optexpr) in
+ let match_comma ea =
+ match A.unwrap ea with
+ A.EComma ia1 -> Some ia1
+ | _ -> None in
+ let build_comma ia1 = A.EComma ia1 in
+ let match_metalist ea =
+ match A.unwrap ea with
+ A.MetaExprList(ida,leninfo,keep,inherited) ->
+ Some(ida,leninfo,keep,inherited)
+ | _ -> None in
+ let build_metalist (ida,leninfo,keep,inherited) =
+ A.MetaExprList(ida,leninfo,keep,inherited) in
+ let mktermval v = Ast_c.MetaExprListVal v in
+ let special_cases ea eas ebs = None in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases argument X.distrf_args
+ Lib_parsing_c.ii_of_args eas ebs
and argument arga argb =
X.all_bound (A.get_inherited arga) >&&>
- match A.unwrap arga, argb with
+ match A.unwrap arga, argb with
| A.TypeExp tya,
Right (B.ArgType {B.p_register=b,iib; p_namei=sopt;p_type=tyb}) ->
-
if b || sopt <> None
then
(* failwith "the argument have a storage and ast_cocci does not have"*)
and parameters_bis eas ebs =
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- (* the management of positions is inlined into each case, because
- sometimes there is a Param and sometimes a ParamList *)
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Pdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if null startxs
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on"*)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Pdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.PComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.PComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.PComma ia1, ebs ->
- (* try optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else parameters_bis eas ebs
-
-
- | A.MetaParamList(ida,leninfo,keep,inherited),ys->
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
- let ok =
- if null startxs
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "I have no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
- if null startxs
- then return (ida, [])
- else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaParamList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- ))
- ) fail
-
-
- | A.VoidParam ta, ys ->
+ let match_dots ea =
+ match A.unwrap ea with
+ A.Pdots(mcode) -> Some (mcode, None)
+ | _ -> None in
+ let build_dots (mcode, _optexpr) = A.Pdots(mcode) in
+ let match_comma ea =
+ match A.unwrap ea with
+ A.PComma ia1 -> Some ia1
+ | _ -> None in
+ let build_comma ia1 = A.PComma ia1 in
+ let match_metalist ea =
+ match A.unwrap ea with
+ A.MetaParamList(ida,leninfo,keep,inherited) ->
+ Some(ida,leninfo,keep,inherited)
+ | _ -> None in
+ let build_metalist (ida,leninfo,keep,inherited) =
+ A.MetaParamList(ida,leninfo,keep,inherited) in
+ let mktermval v = Ast_c.MetaParamListVal v in
+ let special_cases ea eas ebs =
+ (* a case where one smpl parameter matches a list of C parameters *)
+ match A.unwrap ea,ebs with
+ A.VoidParam ta, ys ->
+ Some
(match eas, ebs with
| [], [Left eb] ->
let {B.p_register=(hasreg,iihasreg);
- p_namei = idbopt;
- p_type=tb; } = eb in
-
+ p_namei = idbopt;
+ p_type=tb; } = eb in
+
if idbopt =*= None && not hasreg
then
match tb with
| (qub, (B.BaseType B.Void,_)) ->
fullType ta tb >>= (fun ta tb ->
return (
- [(A.VoidParam ta) +> A.rewrap ea],
- [Left {B.p_register=(hasreg, iihasreg);
- p_namei = idbopt;
- p_type = tb;}]
- ))
+ [(A.VoidParam ta) +> A.rewrap ea],
+ [Left {B.p_register=(hasreg, iihasreg);
+ p_namei = idbopt;
+ p_type = tb;}]
+ ))
| _ -> fail
else fail
- | _ -> fail
- )
-
- | (A.OptParam _ | A.UniqueParam _), _ ->
- failwith "handling Opt/Unique for Param"
-
- | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
-
- | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
- (* todo: use quaopt, hasreg ? *)
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
- X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
- X.distrf_param ida eb
- ) >>= (fun ida eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
- (Left eb)::ebs
- )))
-
-
- | A.Param (typa, idaopt), (Left eb)::ebs ->
- (*this should succeed if the C code has a name, and fail otherwise*)
- parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
- return (
- (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
- (Left eb)::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
+ | _ -> fail)
+ | _ -> None in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases parameter X.distrf_params
+ Lib_parsing_c.ii_of_params eas ebs
+
(*
-let split_register_param = fun (hasreg, idb, ii_b_s) ->
- match hasreg, idb, ii_b_s with
- | false, Some s, [i1] -> Left (s, [], i1)
- | true, Some s, [i1;i2] -> Left (s, [i1], i2)
- | _, None, ii -> Right ii
- | _ -> raise Impossible
+ let split_register_param = fun (hasreg, idb, ii_b_s) ->
+ match hasreg, idb, ii_b_s with
+ | false, Some s, [i1] -> Left (s, [], i1)
+ | true, Some s, [i1;i2] -> Left (s, [i1], i2)
+ | _, None, ii -> Right ii
+ | _ -> raise Impossible
*)
-
-
-and parameter = fun (idaopt, typa) paramb ->
-
- let {B.p_register = (hasreg,iihasreg);
- p_namei = nameidbopt;
- p_type = typb;} = paramb in
-
- fullType typa typb >>= (fun typa typb ->
- match idaopt, nameidbopt with
- | Some ida, Some nameidb ->
+
+
+and parameter = fun parama paramb ->
+ match A.unwrap parama, paramb with
+ A.MetaParam (ida,keep,inherited), eb ->
+ (* todo: use quaopt, hasreg ? *)
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
+ X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
+ X.distrf_param ida eb
+ ) >>= (fun ida eb ->
+ return (A.MetaParam(ida,keep,inherited)+> A.rewrap parama,eb))
+ | A.Param (typa, idaopt), eb ->
+ let {B.p_register = (hasreg,iihasreg);
+ p_namei = nameidbopt;
+ p_type = typb;} = paramb in
+
+ fullType typa typb >>= (fun typa typb ->
+ match idaopt, nameidbopt with
+ | Some ida, Some nameidb ->
(* todo: if minus on ida, should also minus the iihasreg ? *)
- ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
- return (
- (Some ida, typa),
- {B.p_register = (hasreg, iihasreg);
- p_namei = Some (nameidb);
- p_type = typb}
- ))
-
- | None, None ->
- return (
- (None, typa),
- {B.p_register=(hasreg,iihasreg);
- p_namei = None;
- p_type = typb;}
- )
-
-
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
+ return (
+ A.Param (typa, Some ida)+> A.rewrap parama,
+ {B.p_register = (hasreg, iihasreg);
+ p_namei = Some (nameidb);
+ p_type = typb}
+ ))
+
+ | None, None ->
+ return (
+ A.Param (typa, None)+> A.rewrap parama,
+ {B.p_register=(hasreg,iihasreg);
+ p_namei = None;
+ p_type = typb;}
+ )
(* why handle this case ? because of transform_proto ? we may not
* have an ident in the proto.
* If have some plus on ida ? do nothing about ida ?
)
*)
- | Some _, None -> fail
- | None, Some _ -> fail
- )
-
-
-
+ | Some _, None -> fail
+ | None, Some _ -> fail)
+ | (A.OptParam _ | A.UniqueParam _), _ ->
+ failwith "not handling Opt/Unique for Param"
+ | A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
+ | _ -> fail
(* ------------------------------------------------------------------------- *)
and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
* be no transform of MetaDecl, just matching are allowed.
*)
- | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
- (* todo: should not happen in transform mode *)
- return ((mckstart, allminus, decla), declb)
-
-
-
+ | A.MetaDecl (ida,keep,inherited), _ ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_decl declb) in
+ X.envf keep inherited (ida, Ast_c.MetaDeclVal declb, max_min) (fun () ->
+ X.distrf_decl ida declb
+ ) >>= (fun ida declb ->
+ return ((mckstart, allminus,
+ (A.MetaDecl (ida, keep, inherited))+> A.rewrap decla),
+ declb))
| _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
onedecl allminus decla (var,iiptvirgb,iisto) >>=
(fun decla (var,iiptvirgb,iisto)->
(B.DeclList ([var], iiptvirgb::iifakestart::iisto))
)))
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode =*= PatternMode
+ | _, (B.DeclList (xs, ((iiptvirgb::iifakestart::iisto) as ii))) ->
+ let indexify l =
+ let rec loop n = function
+ [] -> []
+ | x::xs -> (n,x)::(loop (n+1) xs) in
+ loop 0 l in
+ let rec repln n vl cur = function
+ [] -> []
+ | x::xs ->
+ if n = cur then vl :: xs else x :: (repln n vl (cur+1) xs) in
+ if X.mode =*= PatternMode || A.get_safe_decl decla
then
- xs +> List.fold_left (fun acc var ->
- acc >||> (
+ (indexify xs) +> List.fold_left (fun acc (n,var) ->
+ (* consider all possible matches *)
+ acc >||> (function tin -> (
X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
onedecl allminus decla (var, iiptvirgb, iisto) >>=
(fun decla (var, iiptvirgb, iisto) ->
return (
(mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))))
+ (* adjust the variable that was chosen *)
+ (B.DeclList (repln n var 0 xs,
+ iiptvirgb::iifakestart::iisto))
+ )))) tin))
fail
else
- failwith "More that one variable in decl. Have to split to transform."
+ error ii
+ "More than one variable in the declaration, and so it cannot be transformed. Check that there is no transformation on the type or the ;"
| A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
[iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
))))))))
- | _, (B.MacroDecl _ |B.DeclList _) -> fail
+ | _, (B.MacroDecl _ |B.DeclList _) -> fail
and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
(* kind of typedef iso, we must unfold, it's for the case
* T { }; that we want to match against typedef struct { } xx_t;
*)
+
| A.TyDecl (tya0, ptvirga),
- ({B.v_namei = Some (nameidb, None);
+ ({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some (nameidb, None);
+ (({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
| _ -> raise Impossible
)
+ (* do we need EnumName here too? *)
| A.StructUnionName(sua, sa) ->
fullType tya2 structnameb >>= (fun tya2 structnameb ->
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some (nameidb, None);
+ (({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
(* could handle iso here but handled in standard.iso *)
| A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some (nameidb, None);
+ ({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
B.v_type_bis = typbbis;
}, iivirg) ->
-
tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
fullType typa typb >>= (fun typa typb ->
ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
(fun stoa (stob, iistob) ->
return (
(A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some (nameidb, None);
+ (({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
)))))
| A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some(nameidb, Some (iieqb, inib));
+ ({B.v_namei = Some(nameidb, B.ValInit (iieqb, inib));
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
initialiser inia inib >>= (fun inia inib ->
return (
(A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some(nameidb, Some (iieqb, inib));
+ (({B.v_namei = Some(nameidb, B.ValInit (iieqb, inib));
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
iiptvirgb,iistob)
)))))))
+ | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
+ ({B.v_namei = Some(nameidb, B.ConstrInit _);
+ B.v_type = typb;
+ B.v_storage = stob;
+ B.v_local = local;
+ B.v_attr = attrs;
+ B.v_type_bis = typbbis;
+ },iivirg)
+ -> fail (* C++ constructor declaration not supported in SmPL *)
+
(* do iso-by-absence here ? allow typedecl and var ? *)
| A.TyDecl (typa, ptvirga),
({B.v_namei = None; B.v_type = typb;
| A.Typedef (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some (nameidb, None);
+ ({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = (B.StoTypedef,inline);
B.v_local = local;
tokenf stoa iitypedef >>= (fun stoa iitypedef ->
return (stoa, [iitypedef])
)
- | _ -> failwith "weird, have both typedef and inline or nothing";
+ | _ -> error iistob "weird, have both typedef and inline or nothing";
) >>= (fun stoa iistob ->
(match A.unwrap ida with
| A.MetaType(_,_,_) ->
) >>= (fun ida nameidb ->
return (
(A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some (nameidb, None);
+ (({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = (B.StoTypedef,inline);
B.v_local = local;
| _ -> fail
)
- | (A.InitList (allminus, ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
+ | (A.ArInitList (ia1, ias, ia2), (B.InitList ibs, ii)) ->
+ (match ii with
+ | ib1::ib2::iicommaopt ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ ar_initialisers (A.undots ias) (ibs, iicommaopt) >>=
+ (fun iasundots (ibs,iicommaopt) ->
+ return (
+ (A.ArInitList (ia1, redots ias iasundots, ia2)) +> A.rewrap ia,
+ (B.InitList ibs, ib1::ib2::iicommaopt)
+ ))))
+
+ | _ -> raise Impossible
+ )
+
+ | (A.StrInitList (allminus, ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
(match ii with
| ib1::ib2::iicommaopt ->
tokenf ia1 ib1 >>= (fun ia1 ib1 ->
tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- initialisers allminus ias (ibs, iicommaopt) >>=
+ str_initialisers allminus ias (ibs, iicommaopt) >>=
(fun ias (ibs,iicommaopt) ->
return (
- (A.InitList (allminus, ia1, ias, ia2, [])) +> A.rewrap ia,
+ (A.StrInitList (allminus, ia1, ias, ia2, [])) +> A.rewrap ia,
(B.InitList ibs, ib1::ib2::iicommaopt)
))))
| _ -> raise Impossible
)
- | (A.InitList (allminus, i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
+ | (A.StrInitList (allminus, i1, ias, i2, whencode),
+ (B.InitList ibs, _ii)) ->
failwith "TODO: not handling whencode in initialisers"
| (_, ((B.DesignatorField _|B.DesignatorIndex _|B.DesignatorRange _), _)) ->
fail
-
-and initialisers = fun allminus ias (ibs, iicomma) ->
+and str_initialisers = fun allminus ias (ibs, iicomma) ->
let ias_unsplit = unsplit_icomma ias in
let ibs_split = resplit_initialiser ibs iicomma in
- let f =
- if need_unordered_initialisers ibs
- then initialisers_unordered2 allminus
- else initialisers_ordered2
- in
- f ias_unsplit ibs_split >>=
- (fun ias_unsplit ibs_split ->
- return (
- split_icomma ias_unsplit,
- unsplit_initialiser ibs_split
- )
- )
+ if need_unordered_initialisers ibs
+ then initialisers_unordered2 allminus ias_unsplit ibs_split >>=
+ (fun ias_unsplit ibs_split ->
+ return (
+ split_icomma ias_unsplit,
+ unsplit_initialiser ibs_split))
+ else fail
+
+and ar_initialisers = fun ias (ibs, iicomma) ->
+ (* this doesn't check need_unordered_initialisers because ... can be
+ implemented as ordered, even if it matches unordered initializers *)
+ let ibs = resplit_initialiser ibs iicomma in
+ let ibs =
+ List.concat
+ (List.map (function (elem,comma) -> [Left elem; Right [comma]]) ibs) in
+ initialisers_ordered2 ias ibs >>=
+ (fun ias ibs_split ->
+ let ibs,iicomma =
+ match List.rev ibs_split with
+ (Right comma)::rest -> (Ast_c.unsplit_comma (List.rev rest),comma)
+ | (Left _)::_ -> (Ast_c.unsplit_comma ibs_split,[]) (* possible *)
+ | [] -> ([],[]) in
+ return (ias, (ibs,iicomma)))
-(* todo: one day julia will reput a IDots *)
and initialisers_ordered2 = fun ias ibs ->
- match ias, ibs with
- | [], [] -> return ([], [])
- | (x, xcomma)::xs, (y, commay)::ys ->
- (match A.unwrap xcomma with
- | A.IComma commax ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- initialisers_ordered2 xs ys >>= (fun xs ys ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
- (y, commay)::ys
- )
- )))
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- | _ -> fail
+ let match_dots ea =
+ match A.unwrap ea with
+ A.Idots(mcode, optexpr) -> Some (mcode, optexpr)
+ | _ -> None in
+ let build_dots (mcode, optexpr) = A.Idots(mcode, optexpr) in
+ let match_comma ea =
+ match A.unwrap ea with
+ A.IComma ia1 -> Some ia1
+ | _ -> None in
+ let build_comma ia1 = A.IComma ia1 in
+ let match_metalist ea = None in
+ let build_metalist (ida,leninfo,keep,inherited) = failwith "not possible" in
+ let mktermval v = failwith "not possible" in
+ let special_cases ea eas ebs = None in
+ let no_ii x = failwith "not possible" in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases initialiser X.distrf_inis no_ii ias ibs
and initialisers_unordered2 = fun allminus ias ibs ->
-
match ias, ibs with
| [], ys ->
if allminus
return(l,(ib,comma)::ibs)))) in
loop ibs
else return ([], ys)
- | (x,xcomma)::xs, ys ->
-
+ | x::xs, ys ->
let permut = Common.uncons_permut_lazy ys in
permut +> List.fold_left (fun acc ((e, pos), rest) ->
acc >||>
- (
- (match A.unwrap xcomma, e with
- | A.IComma commax, (y, commay) ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
- (y, commay))
- )
- )
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
+ (initialiser_comma x e
>>= (fun x e ->
let rest = Lazy.force rest in
initialisers_unordered2 allminus xs rest >>= (fun xs rest ->
))))
) fail
+and initialiser_comma (x,xcomma) (y, commay) =
+ match A.unwrap xcomma with
+ A.IComma commax ->
+ tokenf commax commay >>= (fun commax commay ->
+ initialiser x y >>= (fun x y ->
+ return (
+ (x, (A.IComma commax) +> A.rewrap xcomma),
+ (y, commay))))
+ | _ -> raise Impossible (* unsplit_iicomma wrong *)
(* ------------------------------------------------------------------------- *)
and (struct_fields: (A.declaration list, B.field list) matcher) =
fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.Ddots (mcode, optwhen), ys ->
- if optwhen <> None then failwith "not handling when in argument";
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs =
- if eas = []
- then [(ys,[])] (* hack! the only one that can work *)
- else Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if null startxs
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
-
- X.distrf_struct_fields (dots2metavar mcode) startxs
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- struct_fields eas endxs >>= (fun eas endxs ->
- return (
- (A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
- | _unwrapx, eb::ebs ->
- struct_field ea eb >>= (fun ea eb ->
- struct_fields eas ebs >>= (fun eas ebs ->
- return (ea::eas, eb::ebs)
- ))
-
- | _unwrapx, [] -> fail
- )
+ let match_dots ea =
+ match A.unwrap ea with
+ A.Ddots(mcode, optexpr) -> Some (mcode, optexpr)
+ | _ -> None in
+ let build_dots (mcode, optexpr) = A.Ddots(mcode, optexpr) in
+ let match_comma ea = None in
+ let build_comma ia1 = failwith "not possible" in
+ let match_metalist ea =
+ match A.unwrap ea with
+ A.MetaFieldList(ida,leninfo,keep,inherited) ->
+ Some(ida,leninfo,keep,inherited)
+ | _ -> None in
+ let build_metalist (ida,leninfo,keep,inherited) =
+ A.MetaFieldList(ida,leninfo,keep,inherited) in
+ let mktermval v =
+ (* drop empty ii information, because nothing between elements *)
+ let v = List.map Ast_c.unwrap v in
+ Ast_c.MetaFieldListVal v in
+ let special_cases ea eas ebs = None in
+ let no_ii x = failwith "not possible" in
+ let make_ebs ebs = List.map (function x -> Left x) ebs in
+ let unmake_ebs ebs =
+ List.map (function Left x -> x | Right x -> failwith "no right") ebs in
+ let distrf mcode startxs =
+ let startxs = unmake_ebs startxs in
+ X.distrf_struct_fields mcode startxs >>=
+ (fun mcode startxs -> return (mcode,make_ebs startxs)) in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases struct_field distrf no_ii eas (make_ebs ebs) >>=
+ (fun eas ebs -> return (eas,unmake_ebs ebs))
and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- match fb with
- | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
+ match A.unwrap fa,fb with
+ | A.MetaField (ida,keep,inherited), _ ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_field fb) in
+ X.envf keep inherited (ida, Ast_c.MetaFieldVal fb, max_min) (fun () ->
+ X.distrf_field ida fb
+ ) >>= (fun ida fb ->
+ return ((A.MetaField (ida, keep, inherited))+> A.rewrap fa,
+ fb))
+ | _,B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
let iiptvirgb = tuple_of_list1 iiptvirg in
let iisto = [] in
let stob = B.NoSto, false in
let fake_var =
- ({B.v_namei = Some (nameidb, None);
+ ({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = stob;
B.v_local = Ast_c.NotLocalDecl;
(fun fa (var,iiptvirgb,iisto) ->
match fake_var with
- | ({B.v_namei = Some (nameidb, None);
+ | ({B.v_namei = Some (nameidb, B.NoInit);
B.v_type = typb;
B.v_storage = stob;
}, iivirg) ->
pr2_once "PB: More that one variable in decl. Have to split";
fail
)
- | B.EmptyField _iifield ->
+ | _,B.EmptyField _iifield ->
fail
- | B.MacroDeclField ((sb,ebs),ii) ->
- (match A.unwrap fa with
- A.MacroDecl (sa,lpa,eas,rpa,enda) -> raise Todo
- | _ -> fail)
-
- | B.CppDirectiveStruct directive -> fail
- | B.IfdefStruct directive -> fail
-
-
+ | A.MacroDecl (sa,lpa,eas,rpa,enda),B.MacroDeclField ((sb,ebs),ii) ->
+ raise Todo
+ | _,B.MacroDeclField ((sb,ebs),ii) -> fail
+
+ | _,B.CppDirectiveStruct directive -> fail
+ | _,B.IfdefStruct directive -> fail
+
+
+and enum_fields = fun eas ebs ->
+ let match_dots ea =
+ match A.unwrap ea with
+ A.Edots(mcode, optexpr) -> Some (mcode, optexpr)
+ | _ -> None in
+ let build_dots (mcode, optexpr) = A.Edots(mcode, optexpr) in
+ let match_comma ea =
+ match A.unwrap ea with
+ A.EComma ia1 -> Some ia1
+ | _ -> None in
+ let build_comma ia1 = A.EComma ia1 in
+ let match_metalist ea = None in
+ let build_metalist (ida,leninfo,keep,inherited) = failwith "not possible" in
+ let mktermval v = failwith "not possible" in
+ let special_cases ea eas ebs = None in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases enum_field X.distrf_enum_fields
+ Lib_parsing_c.ii_of_enum_fields eas ebs
+
+and enum_field ida idb =
+ X.all_bound (A.get_inherited ida) >&&>
+ match A.unwrap ida, idb with
+ A.Ident(id),(nameidb,None) ->
+ ident_cpp DontKnow id nameidb >>= (fun id nameidb ->
+ return ((A.Ident id) +> A.rewrap ida, (nameidb,None)))
+ | A.Assignment(ea1,opa,ea2,init),(nameidb,Some(opbi,eb2)) ->
+ (match A.unwrap ea1 with
+ A.Ident(id) ->
+ ident_cpp DontKnow id nameidb >>= (fun id nameidb ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi -> (* only one kind of assignop *)
+ return (
+ (A.Assignment((A.Ident(id))+>A.rewrap ea1,opa,ea2,init)) +>
+ A.rewrap ida,
+ (nameidb,Some(opbi,eb2))))))
+ | _ -> failwith "not possible")
+ | _ -> failwith "not possible"
(* ------------------------------------------------------------------------- *)
and (fullType: (A.fullType, Ast_c.fullType) matcher) =
(* handle some iso on type ? (cf complex C rule for possible implicit
casting) *)
match basea, baseb with
- | A.VoidType, B.Void
- | A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
+ | A.VoidType, B.Void
+ | A.FloatType, B.FloatType (B.CFloat)
+ | A.DoubleType, B.FloatType (B.CDouble)
+ | A.SizeType, B.SizeType
+ | A.SSizeType, B.SSizeType
+ | A.PtrDiffType,B.PtrDiffType ->
assert (signaopt =*= None);
let stringa = tuple_of_list1 stringsa in
let (ibaseb) = tuple_of_list1 ii in
"warning: long double not handled by ast_cocci";
fail
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
+ | _, (B.Void|B.FloatType _|B.IntType _
+ |B.SizeType|B.SSizeType|B.PtrDiffType) -> fail
and simulate_signed_meta ta basea signaopt tb baseb ii rebuilda =
(* In ii there is a list, sometimes of length 1 or 2 or 3.
)
- | (B.Void|B.FloatType _|B.IntType _) -> fail
+ | (B.Void|B.FloatType _|B.IntType _
+ |B.SizeType|B.SSizeType|B.PtrDiffType) -> fail
and (typeC: (A.typeC, Ast_c.typeC) matcher) =
fun ta tb ->
match ii with
[iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
| [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
- | _ -> failwith "list of length 3 or 4 expected" in
+ | _ -> error ii "list of length 3 or 4 expected" in
let process_type =
match (sbopt,ii_sub_sb) with
)
+ | _, (B.NoType, ii) -> fail
| _, (B.TypeOfExpr e, ii) -> fail
| _, (B.TypeOfType e, ii) -> fail
| _, (B.ParenType e, ii) -> fail (* todo ?*)
- | A.EnumName(en,namea), (B.EnumName nameb, ii) ->
+ | A.EnumName(en,Some namea), (B.EnumName nameb, ii) ->
let (ib1,ib2) = tuple_of_list2 ii in
ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
tokenf en ib1 >>= (fun en ib1 ->
return (
- (A.EnumName (en, namea)) +> A.rewrap ta,
+ (A.EnumName (en, Some namea)) +> A.rewrap ta,
(B.EnumName nameb, [ib1;ib2])
)))
+ | A.EnumDef(ty, lba, idsa, rba),
+ (B.Enum (sbopt, idsb), ii) ->
+
+ let (ii_sub_sb, lbb, rbb, comma_opt) =
+ match ii with
+ [iisub; lbb; rbb; comma_opt] ->
+ (Common.Left iisub,lbb,rbb,comma_opt)
+ | [iisub; iisb; lbb; rbb; comma_opt] ->
+ (Common.Right (iisub,iisb),lbb,rbb,comma_opt)
+ | _ -> error ii "list of length 4 or 5 expected" in
+
+ let process_type =
+ match (sbopt,ii_sub_sb) with
+ (None,Common.Left iisub) ->
+ (* the following doesn't reconstruct the complete SP code, just
+ the part that matched *)
+ let rec loop s =
+ match A.unwrap s with
+ A.Type(None,ty) ->
+ (match A.unwrap ty with
+ A.EnumName(sua, None) ->
+ tokenf sua iisub >>= (fun sua iisub ->
+ let ty =
+ A.Type(None,A.EnumName(sua, None) +> A.rewrap ty)
+ +> A.rewrap s in
+ return (ty,[iisub]))
+ | _ -> fail)
+ | A.DisjType(disjs) ->
+ disjs +>
+ List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
+ | _ -> fail in
+ loop ty
+
+ | (Some sb,Common.Right (iisub,iisb)) ->
+
+ (* build an EnumName from an Enum *)
+ let fake_su = B.nQ, (B.EnumName sb, [iisub;iisb]) in
+
+ fullType ty fake_su >>= (fun ty fake_su ->
+ match fake_su with
+ | _nQ, (B.EnumName sb, [iisub;iisb]) ->
+ return (ty, [iisub; iisb])
+ | _ -> raise Impossible)
+ | _ -> fail in
+
+ process_type
+ >>= (fun ty ii_sub_sb ->
+
+ tokenf lba lbb >>= (fun lba lbb ->
+ tokenf rba rbb >>= (fun rba rbb ->
+ let idsb = resplit_initialiser idsb [comma_opt] in
+ let idsb =
+ List.concat
+ (List.map
+ (function (elem,comma) -> [Left elem; Right [comma]])
+ idsb) in
+ enum_fields (A.undots idsa) idsb >>= (fun unidsa idsb ->
+ let idsa = redots idsa unidsa in
+ let idsb,iicomma =
+ match List.rev idsb with
+ (Right comma)::rest ->
+ (Ast_c.unsplit_comma (List.rev rest),comma)
+ | (Left _)::_ -> (Ast_c.unsplit_comma idsb,[]) (* possible *)
+ | [] -> ([],[]) in
+ return (
+ (A.EnumDef(ty, lba, idsa, rba)) +> A.rewrap ta,
+ (B.Enum (sbopt, idsb),ii_sub_sb@[lbb;rbb]@iicomma)
+ ))
+ )))
+
| _, (B.Enum _, _) -> fail (* todo cocci ?*)
| _,
let ok = return ((),()) in
match a, b with
- | Type_cocci.VoidType, B.Void ->
+ | Type_cocci.VoidType, B.Void
+ | Type_cocci.SizeType, B.SizeType
+ | Type_cocci.SSizeType, B.SSizeType
+ | Type_cocci.PtrDiffType, B.PtrDiffType ->
assert (signa =*= None);
ok
| Type_cocci.CharType, B.IntType B.CChar when signa =*= None ->
fail
| Type_cocci.BoolType, _ -> failwith "no booltype in C"
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
+ | _, (B.Void|B.FloatType _|B.IntType _
+ |B.SizeType|B.SSizeType|B.PtrDiffType) -> fail
and compatible_base_type_meta a signa qua b ii local =
match a, b with
pr2_once "no longdouble in cocci";
fail
- | _, (B.Void|B.FloatType _|B.IntType _) -> fail
+ | _, (B.Void|B.FloatType _|B.IntType _
+ |B.SizeType|B.SSizeType|B.PtrDiffType) -> fail
and compatible_type a (b,local) =
let ok = return ((),()) in
let rec loop = function
+ | _, (qua, (B.NoType, _)) ->
+ failwith "compatible_type: matching with NoType"
| Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
compatible_base_type a None b
| Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
(* no size info for cocci *)
loop (a,b)
- | Type_cocci.StructUnionName (sua, _, sa),
+ | Type_cocci.StructUnionName (sua, name),
(qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa =$= sb
- then ok
- else fail
- | Type_cocci.EnumName (_, sa),
- (qub, (B.EnumName (sb),ii)) ->
- if sa =$= sb
- then ok
+ if equal_structUnion_type_cocci sua sub
+ then structure_type_name name sb ii
else fail
+ | Type_cocci.EnumName (name),
+ (qub, (B.EnumName (sb),ii)) -> structure_type_name name sb ii
| Type_cocci.TypeName sa, (qub, (B.TypeName (namesb, _typb),noii)) ->
let sb = Ast_c.str_of_name namesb in
if sa =$= sb
(* kind of typedef iso *)
loop (a,b)
-
-
-
-
(* for metavariables of type expression *^* *)
| Type_cocci.Unknown , _ -> ok
),
_))) -> fail
+and structure_type_name nm sb ii =
+ match nm with
+ Type_cocci.NoName -> ok
+ | Type_cocci.Name sa ->
+ if sa =$= sb
+ then ok
+ else fail
+ | Type_cocci.MV(ida,keep,inherited) ->
+ (* degenerate version of MetaId, no transformation possible *)
+ let (ib1, ib2) = tuple_of_list2 ii in
+ let max_min _ = Lib_parsing_c.lin_col_by_pos [ib2] in
+ let mida = A.make_mcode ida in
+ X.envf keep inherited (mida, B.MetaIdVal (sb,[]), max_min)
+ (fun () -> ok)
in
loop (a,b)
(* todo? facto code with argument and parameters ? *)
and define_paramsbis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | A.DPdots (mcode), ys ->
-
- (* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
- acc >||> (
-
- (if null startxs
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_define_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
- return (
- (A.DPdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | A.DPComma ia1, Right ii::ebs ->
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DPComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.DPComma ia1, ebs ->
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else
- (define_paramsbis eas ebs) (* try optional comma trick *)
-
- | (A.OptDParam _ | A.UniqueDParam _), _ ->
- failwith "handling Opt/Unique for define parameters"
-
- | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
-
- | A.DParam ida, (Left (idb, ii))::ebs ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
- return (
- (A.DParam ida)+> A.rewrap ea :: eas,
- (Left (idb, [ib1]))::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
+ let match_dots ea =
+ match A.unwrap ea with
+ A.DPdots(mcode) -> Some (mcode, None)
+ | _ -> None in
+ let build_dots (mcode, _optexpr) = A.DPdots(mcode) in
+ let match_comma ea =
+ match A.unwrap ea with
+ A.DPComma ia1 -> Some ia1
+ | _ -> None in
+ let build_comma ia1 = A.DPComma ia1 in
+ let match_metalist ea = None in
+ let build_metalist (ida,leninfo,keep,inherited) = failwith "not possible" in
+ let mktermval v = failwith "not possible" in
+ let special_cases ea eas ebs = None in
+ let no_ii x = failwith "not possible" in
+ list_matcher match_dots build_dots match_comma build_comma
+ match_metalist build_metalist mktermval
+ special_cases define_parameter X.distrf_define_params no_ii eas ebs
+
+and define_parameter = fun parama paramb ->
+ match A.unwrap parama, paramb with
+ A.DParam ida, (idb, ii) ->
+ let ib1 = tuple_of_list1 ii in
+ ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
+ return ((A.DParam ida)+> A.rewrap parama,(idb, [ib1])))
+ | (A.OptDParam _ | A.UniqueDParam _), _ ->
+ failwith "handling Opt/Unique for define parameters"
+ | A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
+ | _ -> fail
(*****************************************************************************)
(* Entry points *)
| _, F.EndStatement _ | _, F.CaseNode _
| _, F.TrueNode | _, F.FalseNode | _, F.AfterNode
| _, F.FallThroughNode | _, F.LoopFallThroughNode
- | _, F.InLoopNode
- -> fail2()
+ | _, F.InLoopNode -> fail2()
(* really ? diff between pattern.ml and transformation.ml *)
| _, F.Fake -> fail2()
)))
else fail
+ | A.Undef(undefa,ida), F.DefineHeader ((idb, ii), B.Undef) ->
+ let (defineb, iidb, ieol) = tuple_of_list3 ii in
+ ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ tokenf undefa defineb >>= (fun undefa defineb ->
+ return (
+ A.Undef(undefa,ida),
+ F.DefineHeader ((idb,[defineb;iidb;ieol]),B.Undef)
+ ))
+ )
| A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
(F.Label (_, _, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
F.DefineType _|F.DefineExpr _|F.DefineTodo|
- F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
+ F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|
+ F.MacroIterHeader (_, _)|
F.SwitchHeader (_, _)|F.ForHeader (_, _)|F.DoWhileTail _|F.DoHeader (_, _)|
F.WhileHeader (_, _)|F.Else _|F.IfHeader (_, _)|
F.SeqEnd (_, _)|F.SeqStart (_, _, _)|
HCoop / bpt / coccinelle.git / blobdiff