parsing_cocci/function_prototypes.ml

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