engine/transformation_c.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 open Common
  24
  25 module F = Control_flow_c
  26
  27 (*****************************************************************************)
  28 (* The functor argument  *)
  29 (*****************************************************************************)
  30
  31 (* info passed recursively in monad in addition to binding *)
  32 type xinfo = {
  33   optional_storage_iso : bool;
  34   optional_qualifier_iso : bool;
  35   value_format_iso : bool;
  36   current_rule_name : string; (* used for errors *)
  37 }
  38
  39 module XTRANS = struct
  40
  41   (* ------------------------------------------------------------------------*)
  42   (* Combinators history *)
  43   (* ------------------------------------------------------------------------*)
  44   (*
  45    * version0:
  46    *  type ('a, 'b) transformer =
  47    *    'a -> 'b -> Lib_engine.metavars_binding -> 'b
  48    *  exception NoMatch
  49    *
  50    * version1:
  51    *   type ('a, 'b) transformer =
  52    *    'a -> 'b -> Lib_engine.metavars_binding -> 'b option
  53    * use an exception monad
  54    *
  55    * version2:
  56    *    type tin = Lib_engine.metavars_binding
  57    *)
  58
  59   (* ------------------------------------------------------------------------*)
  60   (* Standard type and operators  *)
  61   (* ------------------------------------------------------------------------*)
  62
  63   type tin = {
  64     extra: xinfo;
  65     binding: Lib_engine.metavars_binding;
  66     binding0: Lib_engine.metavars_binding; (* inherited variable *)
  67   }
  68   type 'x tout = 'x option
  69
  70   type ('a, 'b) matcher = 'a -> 'b  -> tin -> ('a * 'b) tout
  71
  72   let (>>=) m f = fun tin ->
  73      match m tin with
  74      | None -> None
  75      | Some (a,b) -> f a b tin
  76
  77   let return = fun x -> fun tin ->
  78     Some x
  79
  80   (* can have fail in transform now that the process is deterministic ? *)
  81   let fail = fun tin ->
  82     None
  83
  84   let (>||>) m1 m2 = fun tin ->
  85     match m1 tin with
  86     | None -> m2 tin
  87     | Some x -> Some x (* stop as soon as have found something *)
  88
  89   let (>|+|>) m1 m2 = m1 >||> m2
  90
  91   let (>&&>) f m = fun tin ->
  92     if f tin then m tin else fail tin
  93
  94   let optional_storage_flag f = fun tin ->
  95     f (tin.extra.optional_storage_iso) tin
  96
  97   let optional_qualifier_flag f = fun tin ->
  98     f (tin.extra.optional_qualifier_iso) tin
  99
 100   let value_format_flag f = fun tin ->
 101     f (tin.extra.value_format_iso) tin
 102
 103   let mode = Cocci_vs_c.TransformMode
 104
 105   (* ------------------------------------------------------------------------*)
 106   (* Exp  *)
 107   (* ------------------------------------------------------------------------*)
 108   let cocciExp = fun expf expa node -> fun tin ->
 109
 110     let bigf = {
 111       Visitor_c.default_visitor_c_s with
 112       Visitor_c.kexpr_s = (fun (k, bigf) expb ->
 113         match expf expa expb tin with
 114         | None -> (* failed *) k expb
 115         | Some (x, expb) -> expb);
 116     }
 117     in
 118     Some (expa, Visitor_c.vk_node_s bigf node)
 119
 120
 121   (* same as cocciExp, but for expressions in an expression, not expressions
 122      in a node *)
 123   let cocciExpExp = fun expf expa expb -> fun tin ->
 124
 125     let bigf = {
 126       Visitor_c.default_visitor_c_s with
 127       Visitor_c.kexpr_s = (fun (k, bigf) expb ->
 128         match expf expa expb tin with
 129         | None -> (* failed *) k expb
 130         | Some (x, expb) -> expb);
 131     }
 132     in
 133     Some (expa, Visitor_c.vk_expr_s bigf expb)
 134
 135
 136   let cocciTy = fun expf expa node -> fun tin ->
 137
 138     let bigf = {
 139       Visitor_c.default_visitor_c_s with
 140       Visitor_c.ktype_s = (fun (k, bigf) expb ->
 141         match expf expa expb tin with
 142         | None -> (* failed *) k expb
 143         | Some (x, expb) -> expb);
 144     }
 145     in
 146     Some (expa, Visitor_c.vk_node_s bigf node)
 147
 148   let cocciInit = fun expf expa node -> fun tin ->
 149
 150     let bigf = {
 151       Visitor_c.default_visitor_c_s with
 152       Visitor_c.kini_s = (fun (k, bigf) expb ->
 153         match expf expa expb tin with
 154         | None -> (* failed *) k expb
 155         | Some (x, expb) -> expb);
 156     }
 157     in
 158     Some (expa, Visitor_c.vk_node_s bigf node)
 159
 160
 161   (* ------------------------------------------------------------------------*)
 162   (* Tokens *)
 163   (* ------------------------------------------------------------------------*)
 164    let check_pos info mck pos =
 165      match mck with
 166      | Ast_cocci.PLUS -> raise Impossible
 167      | Ast_cocci.CONTEXT (Ast_cocci.FixPos (i1,i2),_)
 168      | Ast_cocci.MINUS   (Ast_cocci.FixPos (i1,i2),_) ->
 169          pos <= i2 && pos >= i1
 170      | Ast_cocci.CONTEXT (Ast_cocci.DontCarePos,_)
 171      | Ast_cocci.MINUS   (Ast_cocci.DontCarePos,_) ->
 172          true
 173      | _ ->
 174          match info with
 175            Some info ->
 176              failwith
 177                (Printf.sprintf
 178                   "weird: dont have position info for the mcodekind in line %d column %d"
 179                   info.Ast_cocci.line info.Ast_cocci.column)
 180          | None ->
 181              failwith "weird: dont have position info for the mcodekind"
 182
 183
 184   let tag_with_mck mck ib = fun tin ->
 185
 186     let cocciinforef = ib.Ast_c.cocci_tag in
 187     let (oldmcode, oldenv) = !cocciinforef in
 188
 189     let mck =
 190       (* coccionly:
 191       if !Flag_parsing_cocci.sgrep_mode
 192       then Sgrep.process_sgrep ib mck
 193       else
 194       *)
 195         mck
 196     in
 197     (match mck, Ast_c.pinfo_of_info ib with
 198     | _,                  Ast_c.AbstractLineTok _ -> raise Impossible
 199     | Ast_cocci.MINUS(_), Ast_c.ExpandedTok _ ->
 200         failwith ("try to delete an expanded token: " ^ (Ast_c.str_of_info ib))
 201     | _ -> ()
 202     );
 203
 204     match (oldmcode,mck) with
 205     | (Ast_cocci.CONTEXT(_,Ast_cocci.NOTHING),      _)
 206     | (_,   Ast_cocci.CONTEXT(_,Ast_cocci.NOTHING))
 207       ->
 208         cocciinforef := (mck, tin.binding);
 209         ib
 210
 211     | _ ->
 212         if (oldmcode, oldenv) =*= (mck, tin.binding)
 213         then begin
 214           if !Flag_matcher.show_misc
 215           then pr2 "already tagged but with same mcode, so safe";
 216           ib
 217         end
 218         else
 219           (* coccionly:
 220           if !Flag.sgrep_mode2
 221           then ib (* safe *)
 222           else
 223           *)
 224              begin
 225             (* coccionly:
 226               Format.set_formatter_out_channel stderr;
 227               Common.pr2 "SP mcode ";
 228               Pretty_print_cocci.print_mcodekind oldmcode;
 229               Format.print_newline();
 230               Common.pr2 "C code mcode ";
 231               Pretty_print_cocci.print_mcodekind mck;
 232               Format.print_newline();
 233               Format.print_flush();
 234             *)
 235               failwith
 236                 (match Ast_c.pinfo_of_info ib with
 237                   Ast_c.FakeTok _ -> "already tagged fake token"
 238                 | _ ->
 239                     Common.sprintf "%s: already tagged token:\n%s"
 240                       tin.extra.current_rule_name
 241                       (Common.error_message (Ast_c.file_of_info ib)
 242                          (Ast_c.str_of_info ib, Ast_c.opos_of_info ib)))
 243             end
 244
 245   let tokenf ia ib = fun tin ->
 246     let (_,i,mck,_) = ia in
 247     let pos = Ast_c.info_to_fixpos ib in
 248     if check_pos (Some i) mck pos
 249     then return (ia, tag_with_mck mck ib tin) tin
 250     else fail tin
 251
 252   let tokenf_mck mck ib = fun tin ->
 253     let pos = Ast_c.info_to_fixpos ib in
 254     if check_pos None mck pos
 255     then return (mck, tag_with_mck mck ib tin) tin
 256     else fail tin
 257
 258
 259   (* ------------------------------------------------------------------------*)
 260   (* Distribute mcode *)
 261   (* ------------------------------------------------------------------------*)
 262
 263   (* When in the SP we attach something to a metavariable, or delete it, as in
 264    * - S
 265    * + foo();
 266    * we have to minusize all the token that compose S in the C code, and
 267    * attach the 'foo();'  to the right token, the one at the very right.
 268    *)
 269
 270   type 'a distributer =
 271       (Ast_c.info -> Ast_c.info) *  (* what to do on left *)
 272       (Ast_c.info -> Ast_c.info) *  (* what to do on middle *)
 273       (Ast_c.info -> Ast_c.info) *  (* what to do on right *)
 274       (Ast_c.info -> Ast_c.info) -> (* what to do on both *)
 275       'a -> 'a
 276
 277   let distribute_mck mcodekind distributef expr tin =
 278     match mcodekind with
 279     | Ast_cocci.MINUS (pos,any_xxs) ->
 280         distributef (
 281           (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,any_xxs)) ib tin),
 282           (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,[])) ib tin),
 283           (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,[])) ib tin),
 284           (fun ib -> tag_with_mck (Ast_cocci.MINUS (pos,any_xxs)) ib tin)
 285         ) expr
 286     | Ast_cocci.CONTEXT (pos,any_befaft) ->
 287         (match any_befaft with
 288         | Ast_cocci.NOTHING -> expr
 289
 290         | Ast_cocci.BEFORE xxs ->
 291             distributef (
 292               (fun ib -> tag_with_mck
 293                 (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin),
 294               (fun x -> x),
 295               (fun x -> x),
 296               (fun ib -> tag_with_mck
 297                 (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin)
 298             ) expr
 299         | Ast_cocci.AFTER xxs ->
 300             distributef (
 301               (fun x -> x),
 302               (fun x -> x),
 303               (fun ib -> tag_with_mck
 304                 (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER xxs)) ib tin),
 305               (fun ib -> tag_with_mck
 306                 (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER xxs)) ib tin)
 307             ) expr
 308
 309         | Ast_cocci.BEFOREAFTER (xxs, yys) ->
 310             distributef (
 311               (fun ib -> tag_with_mck
 312                 (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFORE xxs)) ib tin),
 313               (fun x -> x),
 314               (fun ib -> tag_with_mck
 315                 (Ast_cocci.CONTEXT (pos,Ast_cocci.AFTER yys)) ib tin),
 316               (fun ib -> tag_with_mck
 317                 (Ast_cocci.CONTEXT (pos,Ast_cocci.BEFOREAFTER (xxs,yys)))
 318                 ib tin)
 319             ) expr
 320
 321         )
 322     | Ast_cocci.PLUS -> raise Impossible
 323
 324
 325   (* use new strategy, collect ii, sort, recollect and tag *)
 326
 327   let mk_bigf (maxpos, minpos) (lop,mop,rop,bop) =
 328     let bigf = {
 329       Visitor_c.default_visitor_c_s with
 330         Visitor_c.kinfo_s = (fun (k,bigf) i ->
 331           let pos = Ast_c.info_to_fixpos i in
 332           match () with
 333           | _ when Ast_cocci.equal_pos pos maxpos &&
 334               Ast_cocci.equal_pos pos minpos -> bop i
 335           | _ when Ast_cocci.equal_pos pos maxpos -> rop i
 336           | _ when Ast_cocci.equal_pos pos minpos -> lop i
 337           | _ -> mop i
 338         )
 339     } in
 340     bigf
 341
 342   let distribute_mck_expr (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
 343     Visitor_c.vk_expr_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
 344
 345   let distribute_mck_args (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
 346     Visitor_c.vk_args_splitted_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
 347
 348   let distribute_mck_type (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
 349     Visitor_c.vk_type_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
 350
 351   let distribute_mck_ini (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
 352     Visitor_c.vk_ini_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
 353
 354   let distribute_mck_param (maxpos, minpos) = fun (lop,mop,rop,bop) -> fun x ->
 355     Visitor_c.vk_param_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop)) x
 356
 357   let distribute_mck_params (maxpos, minpos) = fun (lop,mop,rop,bop) ->fun x ->
 358     Visitor_c.vk_params_splitted_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
 359       x
 360
 361   let distribute_mck_node (maxpos, minpos) = fun (lop,mop,rop,bop) ->fun x ->
 362     Visitor_c.vk_node_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
 363       x
 364
 365   let distribute_mck_struct_fields (maxpos, minpos) =
 366     fun (lop,mop,rop,bop) ->fun x ->
 367       Visitor_c.vk_struct_fields_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
 368         x
 369
 370   let distribute_mck_cst (maxpos, minpos) =
 371     fun (lop,mop,rop,bop) ->fun x ->
 372       Visitor_c.vk_cst_s (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
 373         x
 374
 375
 376   let distribute_mck_define_params (maxpos, minpos) = fun (lop,mop,rop,bop) ->
 377    fun x ->
 378     Visitor_c.vk_define_params_splitted_s
 379       (mk_bigf (maxpos, minpos) (lop,mop,rop,bop))
 380       x
 381
 382    let get_pos mck =
 383      match mck with
 384      | Ast_cocci.PLUS -> raise Impossible
 385      | Ast_cocci.CONTEXT (Ast_cocci.FixPos (i1,i2),_)
 386      | Ast_cocci.MINUS   (Ast_cocci.FixPos (i1,i2),_) ->
 387          Ast_cocci.FixPos (i1,i2)
 388      | Ast_cocci.CONTEXT (Ast_cocci.DontCarePos,_)
 389      | Ast_cocci.MINUS   (Ast_cocci.DontCarePos,_) ->
 390          Ast_cocci.DontCarePos
 391      | _ -> failwith "weird: dont have position info for the mcodekind"
 392
 393   let distrf (ii_of_x_f, distribute_mck_x_f) =
 394     fun ia x -> fun tin ->
 395     let mck = Ast_cocci.get_mcodekind ia in
 396     let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
 397     in
 398     if
 399       (* bug: check_pos mck max && check_pos mck min
 400        *
 401        * if do that then if have - f(...); and in C f(1,2); then we
 402        * would get a "already tagged" because the '...' would sucess in
 403        * transformaing both '1' and '1,2'. So being in the range is not
 404        * enough. We must be equal exactly to the range!
 405        *)
 406       (match get_pos mck with
 407       | Ast_cocci.DontCarePos -> true
 408       | Ast_cocci.FixPos (i1, i2) ->
 409           i1 =*= min && i2 =*= max
 410       | _ -> raise Impossible
 411       )
 412
 413     then
 414       return (
 415         ia,
 416         distribute_mck mck (distribute_mck_x_f (max,min))  x tin
 417       ) tin
 418     else fail tin
 419
 420
 421   let distrf_e    = distrf (Lib_parsing_c.ii_of_expr,  distribute_mck_expr)
 422   let distrf_args = distrf (Lib_parsing_c.ii_of_args,  distribute_mck_args)
 423   let distrf_type = distrf (Lib_parsing_c.ii_of_type,  distribute_mck_type)
 424   let distrf_param  = distrf (Lib_parsing_c.ii_of_param, distribute_mck_param)
 425   let distrf_params = distrf (Lib_parsing_c.ii_of_params,distribute_mck_params)
 426   let distrf_ini = distrf (Lib_parsing_c.ii_of_ini,distribute_mck_ini)
 427   let distrf_node = distrf (Lib_parsing_c.ii_of_node,distribute_mck_node)
 428   let distrf_struct_fields =
 429     distrf (Lib_parsing_c.ii_of_struct_fields, distribute_mck_struct_fields)
 430   let distrf_cst =
 431     distrf (Lib_parsing_c.ii_of_cst, distribute_mck_cst)
 432   let distrf_define_params =
 433     distrf (Lib_parsing_c.ii_of_define_params,distribute_mck_define_params)
 434
 435
 436   (* ------------------------------------------------------------------------*)
 437   (* Environment *)
 438   (* ------------------------------------------------------------------------*)
 439   let meta_name_to_str (s1, s2) =
 440     s1 ^ "." ^ s2
 441
 442   let envf keep _inherited = fun (s, value, _) f tin ->
 443     let s = Ast_cocci.unwrap_mcode s in
 444     let v =
 445       if keep =*= Type_cocci.Saved
 446       then (
 447         try Some (List.assoc s tin.binding)
 448         with Not_found ->
 449           pr2(sprintf
 450                 "Don't find value for metavariable %s in the environment"
 451                 (meta_name_to_str s));
 452           None)
 453       else
 454         (* not raise Impossible! *)
 455         Some (value)
 456     in
 457     match v with
 458     | None -> fail tin
 459     | Some (value') ->
 460
 461         (* Ex: in cocci_vs_c someone wants to add a binding. Here in
 462          * transformation3 the value for this var may be already in the
 463          * env, because for instance its value were fixed in a previous
 464          * SmPL rule. So here we want to check that this is the same value.
 465          * If forget to do the check, what can happen ? Because of Exp
 466          * and other disjunctive feature of cocci_vs_c (>||>), we
 467          * may accept a match at a wrong position. Maybe later this
 468          * will be detected via the pos system on tokens, but maybe
 469          * not. So safer to keep the check.
 470          *)
 471
 472         (*f () tin*)
 473         if Cocci_vs_c.equal_metavarval value value'
 474         then f () tin
 475         else fail tin
 476
 477
 478   let check_constraints matcher constraints exp = fun f tin -> f () tin
 479
 480   (* ------------------------------------------------------------------------*)
 481   (* Environment, allbounds *)
 482   (* ------------------------------------------------------------------------*)
 483   let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
 484     true (* in transform we don't care ? *)
 485
 486 end
 487
 488 (*****************************************************************************)
 489 (* Entry point  *)
 490 (*****************************************************************************)
 491 module TRANS  = Cocci_vs_c.COCCI_VS_C (XTRANS)
 492
 493
 494 let transform_re_node a b tin =
 495   match TRANS.rule_elem_node a b tin with
 496   | None -> raise Impossible
 497   | Some (_sp, b') -> b'
 498
 499 let (transform2: string (* rule name *) -> string list (* dropped_isos *) ->
 500   Lib_engine.metavars_binding (* inherited bindings *) ->
 501   Lib_engine.transformation_info -> F.cflow -> F.cflow) =
 502  fun rule_name dropped_isos binding0 xs cflow ->
 503
 504    let extra = {
 505      optional_storage_iso   = not(List.mem "optional_storage" dropped_isos);
 506      optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
 507      value_format_iso = not(List.mem "value_format" dropped_isos);
 508      current_rule_name = rule_name;
 509    } in
 510
 511   (* find the node, transform, update the node,  and iter for all elements *)
 512
 513    xs +> List.fold_left (fun acc (nodei, binding, rule_elem) ->
 514       (* subtil: not cflow#nodes but acc#nodes *)
 515       let node  = acc#nodes#assoc nodei in
 516
 517       if !Flag.show_transinfo
 518       then pr2 "transform one node";
 519
 520       let tin = {
 521         XTRANS.extra = extra;
 522         XTRANS.binding = binding0@binding;
 523         XTRANS.binding0 = []; (* not used - everything constant for trans *)
 524       } in
 525
 526       let node' = transform_re_node rule_elem node tin in
 527
 528       (* assert that have done something. But with metaruleElem sometimes
 529          dont modify fake nodes. So special case before on Fake nodes. *)
 530       (match F.unwrap node with
 531       | F.Enter | F.Exit | F.ErrorExit
 532       | F.EndStatement _ | F.CaseNode _
 533       | F.Fake
 534       | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
 535           -> ()
 536       | _ -> () (* assert (not (node =*= node')); *)
 537       );
 538
 539       (* useless, we dont go back from flow to ast now *)
 540       (* let node' = lastfix_comma_struct node' in *)
 541
 542       acc#replace_node (nodei, node');
 543       acc
 544    ) cflow
 545
 546
 547
 548 let transform a b c d e =
 549   Common.profile_code "Transformation3.transform"
 550     (fun () -> transform2 a b c d e)