-(*
- * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
- * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
- * This file is part of Coccinelle.
- *
- * Coccinelle is free software: you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, according to version 2 of the License.
- *
- * Coccinelle 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
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
- *
- * The authors reserve the right to distribute this or future versions of
- * Coccinelle under other licenses.
- *)
-
-
(* Yoann Padioleau, Julia Lawall
*
* Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
| B.InitDesignators _
| B.InitFieldOld _
| B.InitIndexOld _
- -> true
+ -> true
| B.InitExpr _
| B.InitList _
- -> false
- )
+ -> false)
(* For the #include <linux/...> in the .cocci, need to find where is
* the '+' attached to this element, to later find the first concrete
let equal_metavarval valu valu' =
match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
+ | Ast_c.MetaIdVal (a,_), Ast_c.MetaIdVal (b,_) -> a =$= b
| Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
| Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
(* do something more ? *)
* just isomorphisms). => TODO call isomorphism_c_c instead of
* =*=. Maybe would be easier to transform ast_c in ast_cocci
* and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
+ | Ast_c.MetaExprVal (a,_), Ast_c.MetaExprVal (b,_) ->
Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
| 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.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.MetaTypeVal _ |B.MetaInitVal _
+ |B.MetaDeclVal _ |B.MetaFieldVal _ |B.MetaTypeVal _ |B.MetaInitVal _
|B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
|B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
), _
know which one is which... *)
let equal_inh_metavarval valu valu'=
match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
+ | Ast_c.MetaIdVal (a,_), Ast_c.MetaIdVal (b,_) -> a =$= b
| Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
| Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
(* do something more ? *)
* just isomorphisms). => TODO call isomorphism_c_c instead of
* =*=. Maybe would be easier to transform ast_c in ast_cocci
* and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
+ | Ast_c.MetaExprVal (a,_), Ast_c.MetaExprVal (b,_) ->
Lib_parsing_c.al_inh_expr a =*= Lib_parsing_c.al_inh_expr b
| 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.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.MetaTypeVal _ |B.MetaInitVal _
+ |B.MetaDeclVal _ |B.MetaFieldVal _ |B.MetaTypeVal _ |B.MetaInitVal _
|B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
|B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
), _
(A.meta_name A.mcode, Ast_c.parameterType) matcher
val distrf_ini :
(A.meta_name A.mcode, Ast_c.initialiser) 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
(("","..."),info,mcodekind,pos)
let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-let satisfies_iconstraint c id : bool =
+let satisfies_regexpconstraint c id : bool =
match c with
- A.IdNoConstraint -> true
- | A.IdNegIdSet l -> not (List.mem id l)
- | A.IdRegExp (_,recompiled) ->
- if Str.string_match recompiled id 0 then
- true
- else
- false
- | A.IdNotRegExp (_,recompiled) ->
- if Str.string_match recompiled id 0 then
- false
- else
- true
+ A.IdRegExp (_,recompiled) -> Str.string_match recompiled id 0
+ | A.IdNotRegExp (_,recompiled) -> not (Str.string_match recompiled id 0)
+
+let satisfies_iconstraint c id : bool =
+ not (List.mem id c)
let satisfies_econstraint c exp : bool =
- match Ast_c.unwrap_expr exp with
- Ast_c.Ident (name) ->
- (
- match name with
- Ast_c.RegularName rname -> satisfies_iconstraint c (Ast_c.unwrap_st rname)
- | Ast_c.CppConcatenatedName _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppConcatenatedName identifier !"); true
- | Ast_c.CppVariadicName _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppVariadicName identifier !"); true
- | Ast_c.CppIdentBuilder _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppIdentBuilder identifier !"); true
- )
- | Ast_c.Constant cst ->
- (match cst with
- | Ast_c.String (str, _) -> satisfies_iconstraint c str
- | Ast_c.MultiString strlist ->
- pr2_once ("WARNING: Unable to apply a constraint on an multistring constant !"); true
- | Ast_c.Char (char , _) -> satisfies_iconstraint c char
- | Ast_c.Int (int , _) -> satisfies_iconstraint c int
- | Ast_c.Float (float, _) -> satisfies_iconstraint c float
- )
- | _ -> pr2_once ("WARNING: Unable to apply a constraint on an expression !"); true
+ let warning s = pr2_once ("WARNING: "^s); false in
+ match Ast_c.unwrap_expr exp with
+ Ast_c.Ident (name) ->
+ (match name with
+ Ast_c.RegularName rname ->
+ satisfies_regexpconstraint c (Ast_c.unwrap_st rname)
+ | Ast_c.CppConcatenatedName _ ->
+ warning
+ "Unable to apply a constraint on a CppConcatenatedName identifier!"
+ | Ast_c.CppVariadicName _ ->
+ warning
+ "Unable to apply a constraint on a CppVariadicName identifier!"
+ | Ast_c.CppIdentBuilder _ ->
+ warning
+ "Unable to apply a constraint on a CppIdentBuilder identifier!")
+ | Ast_c.Constant cst ->
+ (match cst with
+ | Ast_c.String (str, _) -> satisfies_regexpconstraint c str
+ | Ast_c.MultiString strlist ->
+ warning "Unable to apply a constraint on an multistring constant!"
+ | Ast_c.Char (char , _) -> satisfies_regexpconstraint c char
+ | Ast_c.Int (int , _) -> satisfies_regexpconstraint c int
+ | Ast_c.Float (float, _) -> satisfies_regexpconstraint c float)
+ | _ -> warning "Unable to apply a constraint on an expression!"
(*---------------------------------------------------------------------------*)
(* toc:
acc >|+|> compatible_type ta tb) fail
) >>=
(fun () () ->
- match constraints with
- Ast_cocci.NoConstraint ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )
-
- | Ast_cocci.NotIdCstrt cstrt ->
- X.check_idconstraint satisfies_econstraint cstrt eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- ))
-
- | Ast_cocci.NotExpCstrt cstrts ->
- X.check_constraints_ne expression cstrts eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )))
+ let meta_expr_val l x = Ast_c.MetaExprVal(x,l) in
+ match constraints with
+ Ast_cocci.NoConstraint -> return (meta_expr_val [],())
+ | Ast_cocci.NotIdCstrt cstrt ->
+ X.check_idconstraint satisfies_econstraint cstrt eb
+ (fun () -> return (meta_expr_val [],()))
+ | Ast_cocci.NotExpCstrt cstrts ->
+ X.check_constraints_ne expression cstrts eb
+ (fun () -> return (meta_expr_val [],()))
+ | Ast_cocci.SubExpCstrt cstrts ->
+ return (meta_expr_val cstrts,()))
+ >>=
+ (fun wrapper () ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
+ X.envf keep inherited (ida, wrapper expb, max_min)
+ (fun () ->
+ X.distrf_e ida expb >>=
+ (fun ida expb ->
+ return (
+ A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
+ A.rewrap ea,
+ expb
+ ))
+ ))
else fail
(* old:
((B.ParenExpr (eb), typ), [ib1;ib2])
))))
- | A.NestExpr(exps,None,true), eb ->
+ | A.NestExpr(starter,exps,ender,None,true), eb ->
+ (match A.get_mcodekind starter with
+ A.MINUS _ -> failwith "TODO: only context nests supported"
+ | _ -> ());
(match A.unwrap exps with
A.DOTS [exp] ->
X.cocciExpExp expression exp eb >>= (fun exp eb ->
return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
+ (A.NestExpr
+ (starter,A.rewrap exps (A.DOTS [exp]),ender,None,true)) +> wa,
eb
)
)
and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
fun infoidb ida ((idb, iib)) -> (* (idb, iib) as ib *)
+ let check_constraints constraints idb =
+ let meta_id_val l x = Ast_c.MetaIdVal(x,l) in
+ match constraints with
+ A.IdNoConstraint -> return (meta_id_val [],())
+ | A.IdNegIdSet (str,meta) ->
+ X.check_idconstraint satisfies_iconstraint str idb
+ (fun () -> return (meta_id_val meta,()))
+ | A.IdRegExpConstraint re ->
+ X.check_idconstraint satisfies_regexpconstraint re idb
+ (fun () -> return (meta_id_val [],())) in
X.all_bound (A.get_inherited ida) >&&>
match A.unwrap ida with
| A.Id sa ->
else fail
| A.MetaId(mida,constraints,keep,inherited) ->
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
(* use drop_pos for ids so that the pos is not added a second time in
the call to tokenf *)
- X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
+ X.envf keep inherited (A.drop_pos mida, wrapper idb, max_min)
(fun () ->
tokenf mida iib >>= (fun mida iib ->
return (
| A.MetaFunc(mida,constraints,keep,inherited) ->
let is_function _ =
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
(fun () ->
| A.MetaLocalFunc(mida,constraints,keep,inherited) ->
(match infoidb with
| LocalFunction ->
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
X.envf keep inherited
(A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
let len = List.length startxs' in
(match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
+ | A.MetaListLen (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()
+ | A.CstListLen n ->
+ if len = n
+ then (function f -> f())
+ else (function f -> fail)
+ | A.AnyListLen -> function f -> f()
)
(fun () ->
let max_min _ =
let len = List.length startxs' in
(match leninfo with
- Some (lenname,lenkeep,leninherited) ->
+ A.MetaListLen (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()
+ | A.CstListLen n ->
+ if len = n
+ then (function f -> f())
+ else (function f -> fail)
+ | A.AnyListLen -> function f -> f()
)
(fun () ->
let max_min _ =
* 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)->
[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_type = typb0;
)
| A.StructUnionName(sua, sa) ->
-
fullType tya2 structnameb >>= (fun tya2 structnameb ->
let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
| _ -> fail
)
- | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
+ | (A.InitList (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 ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
+ initialisers allminus ias (ibs, iicommaopt) >>=
+ (fun ias (ibs,iicommaopt) ->
return (
- (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
+ (A.InitList (allminus, ia1, ias, ia2, [])) +> A.rewrap ia,
(B.InitList ibs, ib1::ib2::iicommaopt)
))))
| _ -> raise Impossible
)
- | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
+ | (A.InitList (allminus, i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
failwith "TODO: not handling whencode in initialisers"
fail
-and initialisers = fun ias (ibs, iicomma) ->
+and 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
+ then initialisers_unordered2 allminus
else initialisers_ordered2
in
f ias_unsplit ibs_split >>=
| _ -> fail
-
-and initialisers_unordered2 = fun ias ibs ->
+and initialisers_unordered2 = fun allminus ias ibs ->
match ias, ibs with
- | [], ys -> return ([], ys)
+ | [], ys ->
+ if allminus
+ then
+ let rec loop = function
+ [] -> return ([],[])
+ | (ib,comma)::ibs ->
+ X.distrf_ini minusizer ib >>= (fun _ ib ->
+ tokenf minusizer comma >>= (fun _ comma ->
+ loop ibs >>= (fun l ibs ->
+ return(l,(ib,comma)::ibs)))) in
+ loop ibs
+ else return ([], ys)
| (x,xcomma)::xs, ys ->
let permut = Common.uncons_permut_lazy ys in
)
>>= (fun x e ->
let rest = Lazy.force rest in
- initialisers_unordered2 xs rest >>= (fun xs rest ->
+ initialisers_unordered2 allminus xs rest >>= (fun xs rest ->
return (
x::xs,
Common.insert_elem_pos (e, pos) rest
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
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)
+ | 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
+ | _,B.CppDirectiveStruct directive -> fail
+ | _,B.IfdefStruct directive -> fail
A.Type(None,ty) ->
(match A.unwrap ty with
A.StructUnionName(sua, None) ->
- tokenf sua iisub >>= (fun sua iisub ->
- let ty =
- A.Type(None,
- A.StructUnionName(sua, None) +> A.rewrap ty)
- +> A.rewrap s in
- return (ty,[iisub]))
+ (match (term sua, sub) with
+ (A.Struct,B.Struct)
+ | (A.Union,B.Union) -> return ((),())
+ | _ -> fail) >>=
+ (fun _ _ ->
+ tokenf sua iisub >>= (fun sua iisub ->
+ let ty =
+ A.Type(None,
+ A.StructUnionName(sua, None) +> A.rewrap ty)
+ +> A.rewrap s in
+ return (ty,[iisub])))
| _ -> fail)
| A.DisjType(disjs) ->
disjs +>
| Some x, ((stobis, inline)) ->
if equal_storage (term x) stobis
then
- match iistob with
- | [i1] ->
- tokenf x i1 >>= (fun x i1 ->
- return (Some x, ((stobis, inline), [i1]))
- )
- (* or if have inline ? have to do a split_storage_inline a la
- * split_signb_baseb_ii *)
- | _ -> raise Impossible
+ let rec loop acc = function
+ [] -> fail
+ | i1::iistob ->
+ let str = B.str_of_info i1 in
+ (match str with
+ "static" | "extern" | "auto" | "register" ->
+ (* not very elegant, but tokenf doesn't know what token to
+ match with *)
+ tokenf x i1 >>= (fun x i1 ->
+ let rebuilt = (List.rev acc) @ i1 :: iistob in
+ return (Some x, ((stobis, inline), rebuilt)))
+ | _ -> loop (i1::acc) iistob) in
+ loop [] iistob
else fail
)
+and inline_optional_allminus allminus inla (stob, iistob) =
+ (* "iso-by-absence" for storage, and return type. *)
+ X.optional_storage_flag (fun optional_storage ->
+ match inla, stob with
+ | None, (stobis, inline) ->
+ let do_minus () =
+ if allminus
+ then
+ minusize_list iistob >>= (fun () iistob ->
+ return (None, (stob, iistob))
+ )
+ else return (None, (stob, iistob))
+ in
+ if inline
+ then
+ if optional_storage
+ then
+ begin
+ if !Flag.show_misc
+ then pr2_once "USING optional_storage builtin isomorphism";
+ do_minus()
+ end
+ else fail (* inline not in SP and present in C code *)
+ else do_minus()
-
+ | Some x, ((stobis, inline)) ->
+ if inline
+ then
+ let rec loop acc = function
+ [] -> fail
+ | i1::iistob ->
+ let str = B.str_of_info i1 in
+ (match str with
+ "inline" ->
+ (* not very elegant, but tokenf doesn't know what token to
+ match with *)
+ tokenf x i1 >>= (fun x i1 ->
+ let rebuilt = (List.rev acc) @ i1 :: iistob in
+ return (Some x, ((stobis, inline), rebuilt)))
+ | _ -> loop (i1::acc) iistob) in
+ loop [] iistob
+ else fail (* SP has inline, but the C code does not *)
+ )
and fullType_optional_allminus allminus tya retb =
match tya with
match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
with [A.FType(t)] -> Some t | _ -> None in
- (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
- with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
+ let inla =
+ match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
+ with [A.FInline(i)] -> Some i | _ -> None in
(match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
(A.undots paramsa) paramsb >>=
(fun paramsaundots paramsb ->
let paramsa = redots paramsa paramsaundots in
+ inline_optional_allminus allminus
+ inla (stob, iistob) >>= (fun inla (stob, iistob) ->
storage_optional_allminus allminus
stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
(
let fninfoa =
(match stoa with Some st -> [A.FStorage st] | None -> []) ++
+ (match inla with Some i -> [A.FInline i] | None -> []) ++
(match tya with Some t -> [A.FType t] | None -> [])
in
},
ioparenb::icparenb::iifakestart::iistob)
)
- ))))))))
+ )))))))))
| _ -> raise Impossible
)
HCoop / bpt / coccinelle.git / blobdiff