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