*)
-(* Yoann Padioleau, Julia Lawall
- *
- * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
- * Copyright (C) 2009, 2010 DIKU, INRIA, LIP6
- *
- * 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 (+++) 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 *)
(*****************************************************************************)
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.MetaTypeVal _ |B.MetaInitVal _
+ |B.MetaDeclVal _ |B.MetaFieldVal _ |B.MetaFieldListVal _
+ |B.MetaTypeVal _ |B.MetaInitVal _
|B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
|B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
), _
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.MetaTypeVal _ |B.MetaInitVal _
+ |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 *)
val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
end
(*****************************************************************************)
| _, ((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"
(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) =
*)
| 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;
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;
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 = None in
- let build_metalist (ida,leninfo,keep,inherited) = failwith "not possible" in
- let mktermval v = 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 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) ->
(* 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
(Common.Left iisub,lbb,rbb,comma_opt)
| [iisub; iisb; lbb; rbb; comma_opt] ->
(Common.Right (iisub,iisb),lbb,rbb,comma_opt)
- | _ -> failwith "list of length 4 or 5 expected" in
+ | _ -> error ii "list of length 4 or 5 expected" in
let process_type =
match (sbopt,ii_sub_sb) with
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
| _, 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