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