parsing_cocci/function_prototypes.ml

   1 (*
   2  * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
   3  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   4  * This file is part of Coccinelle.
   5  *
   6  * Coccinelle is free software: you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation, according to version 2 of the License.
   9  *
  10  * Coccinelle is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17  *
  18  * The authors reserve the right to distribute this or future versions of
  19  * Coccinelle under other licenses.
  20  *)
  21
  22
  23 (*
  24  * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
  25  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
  26  * This file is part of Coccinelle.
  27  *
  28  * Coccinelle is free software: you can redistribute it and/or modify
  29  * it under the terms of the GNU General Public License as published by
  30  * the Free Software Foundation, according to version 2 of the License.
  31  *
  32  * Coccinelle is distributed in the hope that it will be useful,
  33  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  34  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35  * GNU General Public License for more details.
  36  *
  37  * You should have received a copy of the GNU General Public License
  38  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  39  *
  40  * The authors reserve the right to distribute this or future versions of
  41  * Coccinelle under other licenses.
  42  *)
  43
  44
  45 module Ast0 = Ast0_cocci
  46 module Ast = Ast_cocci
  47 module V0 = Visitor_ast0
  48 module VT0 = Visitor_ast0_types
  49
  50 type id = Id of string | Meta of Ast.meta_name
  51
  52 let rec get_name name =
  53   match Ast0.unwrap name with
  54       Ast0.Id(nm) -> Id(Ast0.unwrap_mcode nm)
  55     | Ast0.MetaId(nm,_,_) | Ast0.MetaFunc(nm,_,_)
  56     | Ast0.MetaLocalFunc(nm,_,_) -> Meta(Ast0.unwrap_mcode nm)
  57     | Ast0.OptIdent(id) | Ast0.UniqueIdent(id) ->
  58         get_name id
  59
  60 (* --------------------------------------------------------------------- *)
  61 (* collect all of the functions *)
  62
  63 let brace_to_semi (_,arity,info,mcodekind,pos,adj) =
  64   let info =
  65     (* drop column information, so that with -smpl_spacing the semicolon
  66        will come out right after the close parenthesis *)
  67     {info with Ast0.pos_info = {info.Ast0.pos_info with Ast0.column = -1}} in
  68   (";",Ast0.NONE,info,mcodekind,pos,adj)
  69
  70 let collect_function (stm : Ast0.statement) =
  71   match Ast0.unwrap stm with
  72     Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
  73       let stg =
  74         match
  75           List.filter (function Ast0.FStorage(_) -> true | _ -> false)
  76             fninfo with [Ast0.FStorage(s)] -> Some s | _ -> None in
  77       let ty =
  78         match
  79           List.filter (function Ast0.FType(_) -> true | _ -> false)
  80             fninfo with [Ast0.FType(t)] -> Some t | _ -> None in
  81       [(get_name name,stm,
  82         Ast0.copywrap stm
  83           (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),
  84                      Ast0.copywrap stm
  85                        (Ast0.UnInit
  86                           (stg,
  87                            Ast0.copywrap stm
  88                              (Ast0.FunctionType(ty,lp,params,rp)),
  89                            name,brace_to_semi lbrace)))))]
  90   | _ -> []
  91
  92 let collect_functions stmt_dots =
  93   List.concat (List.map collect_function (Ast0.undots stmt_dots))
  94
  95 let get_all_functions rule =
  96   let res =
  97     match Ast0.unwrap rule with
  98       Ast0.DECL(stmt) -> collect_function stmt
  99     | Ast0.CODE(rule_elem_dots) -> collect_functions rule_elem_dots
 100     | _ -> [] in
 101   List.map
 102     (function (nm,def,vl) ->
 103       (nm,
 104        (def,(Iso_pattern.rebuild_mcode None).VT0.rebuilder_rec_statement vl)))
 105     res
 106
 107 (* --------------------------------------------------------------------- *)
 108 (* try to match up the functions *)
 109
 110 (* pass through the - and + functions in lockstep, until one runs out.
 111 Then process the remaining minuses, if any.  If we can find another
 112 function of the same name for either the current - or + function, take that
 113 one.  Otherwise, align the two current ones. *)
 114
 115 let rec align all_minus all_plus =
 116   let rec loop = function
 117       ([],_) -> []
 118     | ((mname,(mdef,mproto))::minus,[]) ->
 119         (try
 120           let (_,pproto) = List.assoc mname all_plus in
 121           (mname,mdef,mproto,Some pproto)::(loop (minus,[]))
 122         with Not_found -> (mname,mdef,mproto,None)::(loop (minus, [])))
 123     | ((mname,(mdef,mproto))::minus,(pname,(pdef,pproto))::plus) ->
 124         if mname = pname
 125         then (mname,mdef,mproto,Some pproto)::(loop (minus, []))
 126         else
 127           (try
 128             let (_,pproto_for_minus) = List.assoc mname all_plus in
 129             (try
 130               let _ = List.assoc mname all_plus in
 131               (* protos that match both *)
 132               (mname,mdef,mproto,Some pproto_for_minus)::(loop (minus, plus))
 133             with Not_found ->
 134               (* proto that matches only minus *)
 135               (mname,mdef,mproto,Some pproto_for_minus)::
 136               (loop (minus, ((pname,(pdef,pproto))::plus))))
 137           with Not_found ->
 138             (try
 139               let _ = List.assoc mname all_plus in
 140               (* proto only for plus *)
 141               (mname,mdef,mproto,None)::(loop (minus, plus))
 142             with Not_found ->
 143               (* protos for no one *)
 144               (mname,mdef,mproto,Some pproto)::(loop (minus, plus)))) in
 145   List.filter changed_proto (loop (all_minus, all_plus))
 146
 147 (* --------------------------------------------------------------------- *)
 148
 149 and strip =
 150   let donothing r k e =
 151     {(Ast0.wrap (Ast0.unwrap (k e))) with
 152       Ast0.mcodekind = ref  (Ast0.PLUS Ast.ONE)} in
 153   let mcode (mc,_,_,_,_,_) =
 154     (mc,Ast0.NONE,Ast0.default_info(),Ast0.PLUS Ast.ONE,
 155      ref Ast0.NoMetaPos,-1) in
 156
 157   (* need a case for everything that has an unvisited component and can be in
 158      a function prototype *)
 159
 160   let ident r k e =
 161     donothing r k
 162       (Ast0.rewrap e
 163          (match Ast0.unwrap e with
 164            Ast0.MetaId(nm,constraints,pure) ->
 165              Ast0.MetaId(nm,constraints,Ast0.Pure)
 166          | Ast0.MetaFunc(nm,constraints,pure) ->
 167              Ast0.MetaFunc(nm,constraints,Ast0.Pure)
 168          | Ast0.MetaLocalFunc(nm,constraints,pure) ->
 169              Ast0.MetaLocalFunc(nm,constraints,Ast0.Pure)
 170          | e -> e)) in
 171
 172   let typeC r k e =
 173     donothing r k
 174       (Ast0.rewrap e
 175          (match Ast0.unwrap e with
 176            Ast0.MetaType(nm,pure) -> Ast0.MetaType(nm,Ast0.Pure)
 177          | e -> e)) in
 178
 179   let param r k e =
 180     donothing r k
 181       (Ast0.rewrap e
 182          (match Ast0.unwrap e with
 183            Ast0.MetaParam(nm,pure) ->
 184              Ast0.MetaParam(nm,Ast0.Pure)
 185          | Ast0.MetaParamList(nm,lenname,pure) ->
 186              Ast0.MetaParamList(nm,lenname,Ast0.Pure)
 187          | e -> e)) in
 188
 189   V0.flat_rebuilder
 190     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 191     donothing donothing donothing donothing donothing donothing
 192     ident donothing typeC donothing param donothing donothing
 193     donothing donothing
 194
 195 and changed_proto = function
 196     (mname,mdef,mproto,None) -> true
 197   | (mname,mdef,mproto,Some pproto) ->
 198       not ((strip.VT0.rebuilder_rec_statement mproto) =
 199            (strip.VT0.rebuilder_rec_statement pproto))
 200
 201 (* --------------------------------------------------------------------- *)
 202 (* make rules *)
 203
 204 let rec drop_param_name p =
 205   Ast0.rewrap p
 206     (match Ast0.unwrap p with
 207       Ast0.Param(p,_) -> Ast0.Param(p,None)
 208     | Ast0.OptParam(p) -> Ast0.OptParam(drop_param_name p)
 209     | Ast0.UniqueParam(p) -> Ast0.UniqueParam(p)
 210     | p -> p)
 211
 212 let drop_names dec =
 213   let dec = (Iso_pattern.rebuild_mcode None).VT0.rebuilder_rec_statement dec in
 214   match Ast0.unwrap dec with
 215     Ast0.Decl(info,uninit) ->
 216       (match Ast0.unwrap uninit with
 217         Ast0.UnInit(stg,typ,name,sem) ->
 218           (match Ast0.unwrap typ with
 219             Ast0.FunctionType(ty,lp,params,rp) ->
 220               let params =
 221                 match Ast0.unwrap params with
 222                   Ast0.DOTS(l) ->
 223                     Ast0.rewrap params (Ast0.DOTS(List.map drop_param_name l))
 224                 | Ast0.CIRCLES(l) ->
 225                     Ast0.rewrap params
 226                       (Ast0.CIRCLES(List.map drop_param_name l))
 227                 | Ast0.STARS(l) -> failwith "unexpected stars" in
 228               Ast0.rewrap dec
 229                 (Ast0.Decl
 230                    (info,
 231                     Ast0.rewrap uninit
 232                       (Ast0.UnInit
 233                          (stg,
 234                           Ast0.rewrap typ
 235                             (Ast0.FunctionType(ty,lp,params,rp)),
 236                           name,sem))))
 237           | _ -> failwith "function prototypes: unexpected type")
 238       | _ -> failwith "unexpected declaration")
 239   | _ -> failwith "unexpected term"
 240
 241 let ct = ref 0
 242
 243 let new_name name =
 244   let n = !ct in
 245   ct := !ct + 1;
 246   name^"__"^(string_of_int n)
 247
 248 let rec rename_param old_name all param =
 249   match Ast0.unwrap param with
 250     Ast0.Param(ty,Some id) when all ->
 251       (match Ast0.unwrap id with
 252         Ast0.MetaId
 253           (((_,name),arity,info,mcodekind,pos,adj),constraints,pure) ->
 254           let nm = ("__no_name__",new_name name) in
 255           let new_id =
 256             Ast0.rewrap id
 257               (Ast0.MetaId
 258                  ((nm,arity,info,mcodekind,pos,adj),constraints,
 259                   Ast0.Pure)) in
 260           ([Ast.MetaIdDecl(Ast.NONE,nm)],
 261            Ast0.rewrap param (Ast0.Param(ty,Some new_id)))
 262       | _ -> ([],param))
 263   | Ast0.Pdots(d) ->
 264       let nm = (old_name,new_name "__P") in
 265       let nml = (old_name,new_name "__n") in
 266       let new_id =
 267         Ast0.rewrap param
 268           (Ast0.MetaParamList(Ast0.rewrap_mcode d nm,
 269                               Some (Ast0.rewrap_mcode d nml),
 270                               Ast0.Pure)) in
 271       ([Ast.MetaParamListDecl(Ast.NONE,nm,Some nml);Ast.MetaListlenDecl(nml)],
 272        new_id)
 273   | Ast0.OptParam(p) ->
 274       let (metavars,p) = rename_param old_name all p in
 275       (metavars,Ast0.rewrap param (Ast0.OptParam(p)))
 276   | Ast0.UniqueParam(p) ->
 277       let (metavars,p) = rename_param old_name all p in
 278       (metavars,Ast0.rewrap param (Ast0.UniqueParam(p)))
 279   | _ -> ([],param)
 280
 281 (* try to convert names in the - parameter list to new metavariables, to
 282 account for spelling mistakes on the part of the programmer *)
 283 let fresh_names old_name mdef dec =
 284   let res = ([],[],dec,mdef) in
 285   match Ast0.unwrap dec with
 286     Ast0.Decl(info,uninit) ->
 287       (match Ast0.unwrap uninit with
 288         Ast0.UnInit(stg,typ,name,sem) ->
 289           (match Ast0.unwrap typ with
 290             Ast0.FunctionType(ty,lp,params,rp) ->
 291               let (metavars,newdec) =
 292                 let (metavars,l) =
 293                   List.split
 294                     (List.map (rename_param old_name true)
 295                        (Ast0.undots params)) in
 296                 (List.concat metavars,
 297                  Ast0.rewrap dec
 298                    (Ast0.Decl
 299                       (info,
 300                        Ast0.rewrap uninit
 301                          (Ast0.UnInit
 302                             (stg,
 303                              Ast0.rewrap typ
 304                                (Ast0.FunctionType
 305                                   (ty,lp,Ast0.rewrap params (Ast0.DOTS(l)),
 306                                    rp)),
 307                              name,sem))))) in
 308               let (def_metavars,newdef) =
 309                 match Ast0.unwrap mdef with
 310                   Ast0.FunDecl(x,fninfo,name,lp,params,rp,lb,body,rb) ->
 311                     let (def_metavars,def_l) =
 312                       List.split
 313                         (List.map (rename_param old_name false)
 314                            (Ast0.undots params)) in
 315                     (List.concat def_metavars,
 316                      Ast0.rewrap mdef
 317                        (Ast0.FunDecl(x,fninfo,name,lp,
 318                                      Ast0.rewrap params (Ast0.DOTS(def_l)),
 319                                      rp,lb,body,rb)))
 320                    | _ -> failwith "unexpected function definition" in
 321               (metavars,def_metavars,newdec,newdef)
 322           | _ -> res)
 323       | _ -> res)
 324   | _ -> res
 325
 326 (* since there is no + counterpart, the function must be completely deleted *)
 327 let no_names dec =
 328   match Ast0.unwrap dec with
 329     Ast0.Decl(info,uninit) ->
 330       (match Ast0.unwrap uninit with
 331         Ast0.UnInit(stg,typ,name,sem) ->
 332           (match Ast0.unwrap typ with
 333             Ast0.FunctionType(ty,lp,params,rp) ->
 334               Ast0.rewrap dec
 335                 (Ast0.Decl
 336                    (info,
 337                     Ast0.rewrap uninit
 338                       (Ast0.UnInit
 339                          (stg,
 340                           Ast0.rewrap typ
 341                             (Ast0.FunctionType
 342                                (ty,lp,
 343                                 Ast0.rewrap params
 344                                   (let info = Ast0.get_info params in
 345                                   let mcodekind =
 346                                     (* use the mcodekind of an atomic minused
 347                                        thing *)
 348                                     Ast0.get_mcode_mcodekind lp in
 349                                   let pdots =
 350                                     ("...",Ast0.NONE,info,mcodekind,
 351                                      ref Ast0.NoMetaPos,-1) in
 352                                   Ast0.DOTS
 353                                     ([Ast0.rewrap params
 354                                          (Ast0.Pdots(pdots))])),
 355                                 rp)),
 356                           name,sem))))
 357           | _ -> dec)
 358       | _ -> dec)
 359   | _ -> dec
 360
 361 let merge mproto pproto =
 362   let mproto =
 363     Compute_lines.compute_lines true
 364       [Ast0.copywrap mproto (Ast0.DECL mproto)] in
 365   let pproto =
 366     Compute_lines.compute_lines true
 367       [Ast0.copywrap pproto (Ast0.DECL pproto)] in
 368   let (m,p) = List.split(Context_neg.context_neg mproto pproto) in
 369   Insert_plus.insert_plus m p true (* no isos for protos *);
 370   (* convert to ast so that the + code will fall down to the tokens
 371      and off the artificially added Ast0.DECL *)
 372   let mproto = Ast0toast.ast0toast_toplevel (List.hd mproto) in
 373   (* clean up the wrapping added above *)
 374   match Ast.unwrap mproto with
 375     Ast.DECL mproto -> mproto
 376   | _ -> failwith "not possible"
 377
 378 let make_rule rule_name = function
 379     (mname,mdef,mproto,Some pproto) ->
 380       let (metavars,mdef_metavars,mproto,mdef) =
 381         fresh_names rule_name mdef mproto in
 382       let no_name_mproto = drop_names mproto in
 383       let no_name_pproto = drop_names pproto in
 384       (metavars,mdef_metavars,
 385        [merge mproto pproto; merge no_name_mproto no_name_pproto],mdef)
 386   | (mname,mdef,mproto,None) ->
 387       ([],[],[Ast0toast.statement(no_names mproto)],mdef)
 388
 389 (* --------------------------------------------------------------------- *)
 390
 391 let reinsert mdefs minus =
 392   let table =
 393     List.map
 394       (function x ->
 395         match Ast0.unwrap x with
 396           Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
 397             (name,x)
 398         | _ -> failwith "bad mdef")
 399       mdefs in
 400   List.map
 401     (function x ->
 402       match Ast0.unwrap x with
 403         Ast0.DECL(stmt) ->
 404           (match Ast0.unwrap stmt with
 405             Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
 406               (try Ast0.rewrap x (Ast0.DECL(List.assoc name table))
 407               with Not_found -> x)
 408           | _ -> x)
 409       | Ast0.CODE(rule_elem_dots) ->
 410           (* let's hope there are no functions in here... *)
 411           x
 412       | _ -> x)
 413     minus
 414
 415 (* --------------------------------------------------------------------- *)
 416 (* entry point *)
 417
 418 let rec split4 = function
 419     [] -> ([],[],[],[])
 420   | (a,b,c,d)::rest ->
 421       let (ax,bx,cx,dx) = split4 rest in (a::ax,b::bx,c::cx,d::dx)
 422
 423 let process rule_name rule_metavars dropped_isos minus plus ruletype =
 424   let minus_functions = List.concat (List.map get_all_functions minus) in
 425   match minus_functions with
 426     [] -> ((rule_metavars,minus),None)
 427   | _ ->
 428       let plus_functions =
 429         List.concat (List.map get_all_functions plus) in
 430       let protos = align minus_functions plus_functions in
 431       let (metavars,mdef_metavars,rules,mdefs) =
 432         split4(List.map (make_rule rule_name) protos) in
 433       let metavars = List.concat metavars in
 434       let mdef_metavars = (List.concat mdef_metavars) @ rule_metavars in
 435       let rules = List.concat rules in
 436       let minus = reinsert mdefs minus in
 437       match rules with
 438         [] -> ((rule_metavars,minus),None)
 439       | [x] ->
 440           (* probably not possible, since there is always the version with
 441              variables and the version without *)
 442           ((mdef_metavars,minus),
 443            Some
 444              (metavars,
 445               Ast.CocciRule
 446                 ("proto for "^rule_name,
 447                  (Ast.Dep rule_name,dropped_isos,Ast.Forall),
 448                  [Ast.rewrap x (Ast.DECL x)],
 449                  [false],ruletype)))
 450       | x::_ ->
 451           let drules =
 452             List.map (function x -> Ast.rewrap x (Ast.DOTS [x])) rules in
 453           let res =
 454             Ast.CocciRule
 455             ("proto for "^rule_name,
 456              (Ast.Dep rule_name,dropped_isos,Ast.Forall),
 457              [Ast.rewrap x (Ast.DECL (Ast.rewrap x (Ast.Disj drules)))],
 458              [false],ruletype) in
 459           ((mdef_metavars,minus),Some(metavars,res))