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