engine/.#transformation3.ml.1.47

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