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 module Ast0 = Ast0_cocci
  28 module Ast = Ast_cocci
  29 module V0 = Visitor_ast0
  30 module VT0 = Visitor_ast0_types
  31
  32 type id = Id of string | Meta of Ast.meta_name
  33
  34 let rec get_name name =
  35   match Ast0.unwrap name with
  36     Ast0.Id(nm) -> [Id(Ast0.unwrap_mcode nm)]
  37   | Ast0.MetaId(nm,_,_,_) | Ast0.MetaFunc(nm,_,_)
  38   | Ast0.MetaLocalFunc(nm,_,_) -> [Meta(Ast0.unwrap_mcode nm)]
  39   | Ast0.DisjId(_,id_list,_,_) -> List.concat (List.map get_name id_list)
  40   | Ast0.OptIdent(id) | Ast0.UniqueIdent(id) ->
  41       get_name id
  42
  43 (* --------------------------------------------------------------------- *)
  44 (* collect all of the functions *)
  45
  46 let brace_to_semi (_,arity,info,mcodekind,pos,adj) =
  47   let info =
  48     (* drop column information, so that with -smpl_spacing the semicolon
  49        will come out right after the close parenthesis *)
  50     {info with Ast0.pos_info = {info.Ast0.pos_info with Ast0.column = -1}} in
  51   (";",Ast0.NONE,info,mcodekind,pos,adj)
  52
  53 let collect_function (stm : Ast0.statement) =
  54   match Ast0.unwrap stm with
  55     Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
  56       let stg =
  57         match
  58           List.filter (function Ast0.FStorage(_) -> true | _ -> false)
  59             fninfo with [Ast0.FStorage(s)] -> Some s | _ -> None in
  60       let ty =
  61         match
  62           List.filter (function Ast0.FType(_) -> true | _ -> false)
  63             fninfo with [Ast0.FType(t)] -> Some t | _ -> None in
  64       List.map
  65         (function nm ->
  66           (nm,stm,
  67            Ast0.copywrap stm
  68              (Ast0.Decl((Ast0.default_info(),Ast0.context_befaft()),
  69                         Ast0.copywrap stm
  70                           (Ast0.UnInit
  71                              (stg,
  72                               Ast0.copywrap stm
  73                                 (Ast0.FunctionType(ty,lp,params,rp)),
  74                               name,brace_to_semi lbrace))))))
  75         (get_name name)
  76   | _ -> []
  77
  78 let collect_functions stmt_dots =
  79   List.concat (List.map collect_function (Ast0.undots stmt_dots))
  80
  81 let drop_positions =
  82   let mcode (term,arity,info,mc,_,adj) =
  83     (term,arity,info,mc,ref [],adj) in
  84   let donothing r k e = k e in
  85   let res =
  86     V0.flat_rebuilder
  87     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
  88     donothing donothing donothing donothing donothing donothing
  89     donothing donothing donothing donothing donothing donothing donothing
  90     donothing donothing in
  91   res.VT0.rebuilder_rec_statement
  92
  93 let get_all_functions rule =
  94   let res =
  95     match Ast0.unwrap rule with
  96       Ast0.NONDECL(stmt) -> collect_function stmt
  97     | Ast0.CODE(rule_elem_dots) -> collect_functions rule_elem_dots
  98     | _ -> [] in
  99   List.map
 100     (function (nm,def,vl) ->
 101       (nm,
 102        (def,
 103         drop_positions
 104           ((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 [],-1) in
 156
 157   (* need a case for everything that has an unvisited component and can be in
 158      a function prototype.  Also get rid of constraints because pcre
 159      constraints cannot be compared. *)
 160
 161   let ident r k e =
 162     donothing r k
 163       (Ast0.rewrap e
 164          (match Ast0.unwrap e with
 165            Ast0.MetaId(nm,constraints,seed,pure) ->
 166              Ast0.MetaId(nm,Ast.IdNoConstraint,seed,Ast0.Pure)
 167          | Ast0.MetaFunc(nm,constraints,pure) ->
 168              Ast0.MetaFunc(nm,Ast.IdNoConstraint,Ast0.Pure)
 169          | Ast0.MetaLocalFunc(nm,constraints,pure) ->
 170              Ast0.MetaLocalFunc(nm,Ast.IdNoConstraint,Ast0.Pure)
 171          | e -> e)) in
 172
 173   let typeC r k e =
 174     donothing r k
 175       (Ast0.rewrap e
 176          (match Ast0.unwrap e with
 177            Ast0.MetaType(nm,pure) -> Ast0.MetaType(nm,Ast0.Pure)
 178          | e -> e)) in
 179
 180   let param r k e =
 181     donothing r k
 182       (Ast0.rewrap e
 183          (match Ast0.unwrap e with
 184            Ast0.MetaParam(nm,pure) ->
 185              Ast0.MetaParam(nm,Ast0.Pure)
 186          | Ast0.MetaParamList(nm,lenname,pure) ->
 187              Ast0.MetaParamList(nm,lenname,Ast0.Pure)
 188          | e -> e)) in
 189
 190   V0.flat_rebuilder
 191     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 192     donothing donothing donothing donothing donothing donothing
 193     ident donothing typeC donothing param donothing donothing
 194     donothing donothing
 195
 196 and changed_proto = function
 197     (mname,mdef,mproto,None) -> true
 198   | (mname,mdef,mproto,Some pproto) ->
 199       not ((strip.VT0.rebuilder_rec_statement mproto) =
 200            (strip.VT0.rebuilder_rec_statement pproto))
 201
 202 (* --------------------------------------------------------------------- *)
 203 (* make rules *)
 204
 205 let rec drop_param_name p =
 206   Ast0.rewrap p
 207     (match Ast0.unwrap p with
 208       Ast0.Param(p,_) -> Ast0.Param(p,None)
 209     | Ast0.OptParam(p) -> Ast0.OptParam(drop_param_name p)
 210     | Ast0.UniqueParam(p) -> Ast0.UniqueParam(p)
 211     | p -> p)
 212
 213 let drop_names dec =
 214   let dec = (Iso_pattern.rebuild_mcode None).VT0.rebuilder_rec_statement dec in
 215   match Ast0.unwrap dec with
 216     Ast0.Decl(info,uninit) ->
 217       (match Ast0.unwrap uninit with
 218         Ast0.UnInit(stg,typ,name,sem) ->
 219           (match Ast0.unwrap typ with
 220             Ast0.FunctionType(ty,lp,params,rp) ->
 221               let params =
 222                 match Ast0.unwrap params with
 223                   Ast0.DOTS(l) ->
 224                     Ast0.rewrap params (Ast0.DOTS(List.map drop_param_name l))
 225                 | Ast0.CIRCLES(l) ->
 226                     Ast0.rewrap params
 227                       (Ast0.CIRCLES(List.map drop_param_name l))
 228                 | Ast0.STARS(l) -> failwith "unexpected stars" in
 229               Ast0.rewrap dec
 230                 (Ast0.Decl
 231                    (info,
 232                     Ast0.rewrap uninit
 233                       (Ast0.UnInit
 234                          (stg,
 235                           Ast0.rewrap typ
 236                             (Ast0.FunctionType(ty,lp,params,rp)),
 237                           name,sem))))
 238           | _ -> failwith "function prototypes: unexpected type")
 239       | _ -> failwith "unexpected declaration")
 240   | _ -> failwith "unexpected term"
 241
 242 let ct = ref 0
 243
 244 let new_name name =
 245   let n = !ct in
 246   ct := !ct + 1;
 247   name^"__"^(string_of_int n)
 248
 249 let rec rename_param old_name all param =
 250   match Ast0.unwrap param with
 251     Ast0.Param(ty,Some id) when all ->
 252       (match Ast0.unwrap id with
 253         Ast0.MetaId
 254           (((_,name),arity,info,mcodekind,pos,adj),constraints,seed,pure) ->
 255           let nm = ("__no_name__",new_name name) in
 256           let new_id =
 257             Ast0.rewrap id
 258               (Ast0.MetaId
 259                  ((nm,arity,info,mcodekind,pos,adj),constraints,seed,
 260                   Ast0.Pure)) in
 261           ([Ast.MetaIdDecl(Ast.NONE,nm)],
 262            Ast0.rewrap param (Ast0.Param(ty,Some new_id)))
 263       | _ -> ([],param))
 264   | Ast0.Pdots(d) ->
 265       let nm = (old_name,new_name "__P") in
 266       let nml = (old_name,new_name "__n") in
 267       let new_id =
 268         Ast0.rewrap param
 269           (Ast0.MetaParamList(Ast0.rewrap_mcode d nm,
 270                               Ast0.MetaListLen (Ast0.rewrap_mcode d nml),
 271                               Ast0.Pure)) in
 272       ([Ast.MetaParamListDecl(Ast.NONE,nm,Ast.MetaLen nml);
 273          Ast.MetaListlenDecl(nml)],
 274        new_id)
 275   | Ast0.OptParam(p) ->
 276       let (metavars,p) = rename_param old_name all p in
 277       (metavars,Ast0.rewrap param (Ast0.OptParam(p)))
 278   | Ast0.UniqueParam(p) ->
 279       let (metavars,p) = rename_param old_name all p in
 280       (metavars,Ast0.rewrap param (Ast0.UniqueParam(p)))
 281   | _ -> ([],param)
 282
 283 (* try to convert names in the - parameter list to new metavariables, to
 284 account for spelling mistakes on the part of the programmer *)
 285 let fresh_names old_name mdef dec =
 286   let res = ([],[],dec,mdef) in
 287   match Ast0.unwrap dec with
 288     Ast0.Decl(info,uninit) ->
 289       (match Ast0.unwrap uninit with
 290         Ast0.UnInit(stg,typ,name,sem) ->
 291           (match Ast0.unwrap typ with
 292             Ast0.FunctionType(ty,lp,params,rp) ->
 293               let (metavars,newdec) =
 294                 let (metavars,l) =
 295                   List.split
 296                     (List.map (rename_param old_name true)
 297                        (Ast0.undots params)) in
 298                 (List.concat metavars,
 299                  Ast0.rewrap dec
 300                    (Ast0.Decl
 301                       (info,
 302                        Ast0.rewrap uninit
 303                          (Ast0.UnInit
 304                             (stg,
 305                              Ast0.rewrap typ
 306                                (Ast0.FunctionType
 307                                   (ty,lp,Ast0.rewrap params (Ast0.DOTS(l)),
 308                                    rp)),
 309                              name,sem))))) in
 310               let (def_metavars,newdef) =
 311                 match Ast0.unwrap mdef with
 312                   Ast0.FunDecl(x,fninfo,name,lp,params,rp,lb,body,rb) ->
 313                     let (def_metavars,def_l) =
 314                       List.split
 315                         (List.map (rename_param old_name false)
 316                            (Ast0.undots params)) in
 317                     (List.concat def_metavars,
 318                      Ast0.rewrap mdef
 319                        (Ast0.FunDecl(x,fninfo,name,lp,
 320                                      Ast0.rewrap params (Ast0.DOTS(def_l)),
 321                                      rp,lb,body,rb)))
 322                    | _ -> failwith "unexpected function definition" in
 323               (metavars,def_metavars,newdec,newdef)
 324           | _ -> res)
 325       | _ -> res)
 326   | _ -> res
 327
 328 (* since there is no + counterpart, the function must be completely deleted *)
 329 let no_names dec =
 330   match Ast0.unwrap dec with
 331     Ast0.Decl(info,uninit) ->
 332       (match Ast0.unwrap uninit with
 333         Ast0.UnInit(stg,typ,name,sem) ->
 334           (match Ast0.unwrap typ with
 335             Ast0.FunctionType(ty,lp,params,rp) ->
 336               Ast0.rewrap dec
 337                 (Ast0.Decl
 338                    (info,
 339                     Ast0.rewrap uninit
 340                       (Ast0.UnInit
 341                          (stg,
 342                           Ast0.rewrap typ
 343                             (Ast0.FunctionType
 344                                (ty,lp,
 345                                 Ast0.rewrap params
 346                                   (let info = Ast0.get_info params in
 347                                   let mcodekind =
 348                                     (* use the mcodekind of an atomic minused
 349                                        thing *)
 350                                     Ast0.get_mcode_mcodekind lp in
 351                                   let pdots =
 352                                     ("...",Ast0.NONE,info,mcodekind,
 353                                      ref [],-1) in
 354                                   Ast0.DOTS
 355                                     ([Ast0.rewrap params
 356                                          (Ast0.Pdots(pdots))])),
 357                                 rp)),
 358                           name,sem))))
 359           | _ -> dec)
 360       | _ -> dec)
 361   | _ -> dec
 362
 363 let mkcode proto =
 364   Ast0.copywrap proto (Ast0.CODE(Ast0.copywrap proto (Ast0.DOTS [proto])))
 365
 366 let merge mproto pproto =
 367   let mproto = Compute_lines.compute_lines true [mkcode mproto] in
 368   let pproto = Compute_lines.compute_lines true [mkcode pproto] in
 369   let (m,p) = List.split(Context_neg.context_neg mproto pproto) in
 370   Insert_plus.insert_plus m p true (* no isos for protos *);
 371   (* convert to ast so that the + code will fall down to the tokens
 372      and off the artificially added Ast0.CODE *)
 373   let mproto = Ast0toast.ast0toast_toplevel (List.hd mproto) in
 374   (* clean up the wrapping added above *)
 375   match Ast.unwrap mproto with
 376     Ast.CODE mproto -> List.hd (Ast.undots mproto)
 377   | _ -> failwith "not possible"
 378
 379 let make_rule rule_name = function
 380     (mname,mdef,mproto,Some pproto) ->
 381       let (metavars,mdef_metavars,mproto,mdef) =
 382         fresh_names rule_name mdef mproto in
 383       let no_name_mproto = drop_names mproto in
 384       let no_name_pproto = drop_names pproto in
 385       (metavars,mdef_metavars,
 386        [merge mproto pproto; merge no_name_mproto no_name_pproto],mdef)
 387   | (mname,mdef,mproto,None) ->
 388       ([],[],[Ast0toast.statement(no_names mproto)],mdef)
 389
 390 (* --------------------------------------------------------------------- *)
 391
 392 let reinsert mdefs minus =
 393   let table =
 394     List.map
 395       (function x ->
 396         match Ast0.unwrap x with
 397           Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
 398             (name,x)
 399         | _ -> failwith "bad mdef")
 400       mdefs in
 401   List.map
 402     (function x ->
 403       match Ast0.unwrap x with
 404         Ast0.NONDECL(stmt) ->
 405           (match Ast0.unwrap stmt with
 406             Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
 407               (try Ast0.rewrap x (Ast0.NONDECL(List.assoc name table))
 408               with Not_found -> x)
 409           | _ -> x)
 410       | Ast0.CODE(rule_elem_dots) ->
 411           (* let's hope there are no functions in here... *)
 412           x
 413       | _ -> x)
 414     minus
 415
 416 (* --------------------------------------------------------------------- *)
 417 (* entry point *)
 418
 419 let rec split4 = function
 420     [] -> ([],[],[],[])
 421   | (a,b,c,d)::rest ->
 422       let (ax,bx,cx,dx) = split4 rest in (a::ax,b::bx,c::cx,d::dx)
 423
 424 let mk_ast_code proto =
 425   Ast.rewrap proto (Ast.CODE(Ast.rewrap proto (Ast.DOTS [proto])))
 426
 427 let process rule_name rule_metavars dropped_isos minus plus ruletype =
 428   let minus_functions = List.concat (List.map get_all_functions minus) in
 429   match minus_functions with
 430     [] -> ((rule_metavars,minus),None)
 431   | _ ->
 432       let plus_functions =
 433         List.concat (List.map get_all_functions plus) in
 434       let protos = align minus_functions plus_functions in
 435       let (metavars,mdef_metavars,rules,mdefs) =
 436         split4(List.map (make_rule rule_name) protos) in
 437       let metavars = List.concat metavars in
 438       let mdef_metavars = (List.concat mdef_metavars) @ rule_metavars in
 439       let rules = List.concat rules in
 440       let minus = reinsert mdefs minus in
 441       match rules with
 442         [] -> ((rule_metavars,minus),None)
 443       | [x] ->
 444           (* probably not possible, since there is always the version with
 445              variables and the version without *)
 446           ((mdef_metavars,minus),
 447            Some
 448              (metavars,
 449               Ast.CocciRule
 450                 ("proto for "^rule_name,
 451                  (Ast.Dep rule_name,dropped_isos,Ast.Forall),
 452                  [mk_ast_code x],
 453                  [false],ruletype)))
 454       | x::_ ->
 455           let drules =
 456             List.map (function x -> Ast.rewrap x (Ast.DOTS [x])) rules in
 457           let res =
 458             Ast.CocciRule
 459             ("proto for "^rule_name,
 460              (Ast.Dep rule_name,dropped_isos,Ast.Forall),
 461              [mk_ast_code (Ast.rewrap x (Ast.Disj drules))],
 462              [false],ruletype) in
 463           ((mdef_metavars,minus),Some(metavars,res))