parsing_cocci/function_prototypes.ml

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