parsing_cocci/function_prototypes.ml

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