parsing_cocci/function_prototypes.ml

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