parsing_cocci/function_prototypes.ml

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