engine/pattern_c.ml

   1 (*
   2  * Copyright 2012, INRIA
   3  * Julia Lawall, Gilles Muller
   4  * Copyright 2010-2011, INRIA, University of Copenhagen
   5  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
   6  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   7  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   8  * This file is part of Coccinelle.
   9  *
  10  * Coccinelle is free software: you can redistribute it and/or modify
  11  * it under the terms of the GNU General Public License as published by
  12  * the Free Software Foundation, according to version 2 of the License.
  13  *
  14  * Coccinelle is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  21  *
  22  * The authors reserve the right to distribute this or future versions of
  23  * Coccinelle under other licenses.
  24  *)
  25
  26
  27 open Common
  28
  29 module Flag_engine = Flag_matcher
  30 (*****************************************************************************)
  31 (* The functor argument  *)
  32 (*****************************************************************************)
  33
  34 (* info passed recursively in monad in addition to binding *)
  35 type xinfo = {
  36   optional_storage_iso : bool;
  37   optional_qualifier_iso : bool;
  38   value_format_iso : bool;
  39   optional_declarer_semicolon_iso : bool;
  40 }
  41
  42 module XMATCH = struct
  43
  44   (* ------------------------------------------------------------------------*)
  45   (* Combinators history *)
  46   (* ------------------------------------------------------------------------*)
  47   (*
  48    * version0:
  49    *   type ('a, 'b) matcher = 'a -> 'b -> bool
  50    *
  51    * version1: same but with a global variable holding the current binding
  52    *  BUT bug
  53    *   - can have multiple possibilities
  54    *   - globals sux
  55    *   - sometimes have to undo, cos if start match, then it binds,
  56    *     and if later it does not match, then must undo the first binds.
  57    *     ex: when match parameters, can  try to match, but then we found far
  58    *     later that the last argument of a function does not match
  59    *      => have to uando the binding !!!
  60    *      (can handle that too with a global, by saving the
  61    *      global, ... but sux)
  62    *   => better not use global
  63    *
  64    * version2:
  65    *    type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
  66    *
  67    * Empty list mean failure (let matchfailure = []).
  68    * To be able to have pretty code, have to use partial application
  69    * powa, and so the type is in fact
  70    *
  71    * version3:
  72    *    type ('a, 'b) matcher =  'a -> 'b -> binding -> binding list
  73    *
  74    * Then by defining the correct combinators, can have quite pretty code (that
  75    * looks like the clean code of version0).
  76    *
  77    * opti: return a lazy list of possible matchs ?
  78    *
  79    * version4: type tin = Lib_engine.metavars_binding
  80    *)
  81
  82   (* ------------------------------------------------------------------------*)
  83   (* Standard type and operators  *)
  84   (* ------------------------------------------------------------------------*)
  85
  86   type tin = {
  87     extra: xinfo;
  88     binding: Lib_engine.metavars_binding;
  89     binding0: Lib_engine.metavars_binding; (* inherited bindings *)
  90   }
  91   (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
  92   (* opti? use set instead of list *)
  93   type 'x tout = ('x * Lib_engine.metavars_binding) list
  94
  95   type ('a, 'b) matcher = 'a -> 'b  -> tin -> ('a * 'b) tout
  96
  97   (* was >&&> *)
  98   let (>>=) m1 m2 = fun tin ->
  99     let xs = m1 tin in
 100     let xxs = xs +> List.map (fun ((a,b), binding) ->
 101       m2 a b {tin with binding = binding}
 102     ) in
 103     List.flatten xxs
 104
 105   (* Je compare les bindings retournés par les differentes branches.
 106    * Si la deuxieme branche amene a des bindings qui sont deja presents
 107    * dans la premiere branche, alors je ne les accepte pas.
 108    *
 109    * update: still useful now that julia better handle Exp directly via
 110    * ctl tricks using positions ?
 111    *)
 112   let (>|+|>) m1 m2 = fun tin ->
 113 (* CHOICE
 114       let xs = m1 tin in
 115       if null xs
 116       then m2 tin
 117       else xs
 118 *)
 119     let res1 = m1 tin in
 120     let res2 = m2 tin in
 121     let list_bindings_already = List.map snd res1 in
 122     res1 ++
 123       (res2 +> List.filter (fun (x, binding) ->
 124         not
 125           (list_bindings_already +> List.exists (fun already ->
 126             Lib_engine.equal_binding binding already))
 127       ))
 128
 129
 130
 131
 132   let (>||>) m1 m2 = fun tin ->
 133 (* CHOICE
 134       let xs = m1 tin in
 135       if null xs
 136       then m2 tin
 137       else xs
 138 *)
 139     (* opti? use set instead of list *)
 140     let l1 = m1 tin in
 141     let l2 = m2 tin in
 142     if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
 143
 144
 145   let return res = fun tin ->
 146     [res, tin.binding]
 147
 148   let fail = fun tin ->
 149     []
 150
 151   let (>&&>) f m = fun tin ->
 152     if f tin
 153     then m tin
 154     else fail tin
 155
 156
 157   let mode = Cocci_vs_c.PatternMode
 158
 159   (* ------------------------------------------------------------------------*)
 160   (* Exp  *)
 161   (* ------------------------------------------------------------------------*)
 162   let cocciExp = fun expf expa node -> fun tin ->
 163
 164     let globals = ref [] in
 165     let bigf = {
 166       (* julia's style *)
 167       Visitor_c.default_visitor_c with
 168       Visitor_c.kexpr = (fun (k, bigf) expb ->
 169         match expf expa expb tin with
 170         | [] -> (* failed *) k expb
 171         | xs ->
 172             globals := xs @ !globals;
 173             if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
 174       );
 175       (* pad's style.
 176        * push2 expr globals;  k expr
 177        *  ...
 178        *  !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
 179        * (return false)
 180        *
 181        *)
 182     }
 183     in
 184     Visitor_c.vk_node bigf node;
 185     !globals +> List.map (fun ((a, _exp), binding) ->
 186       (a, node), binding
 187     )
 188
 189   (* same as cocciExp, but for expressions in an expression, not expressions
 190      in a node *)
 191   let cocciExpExp = fun expf expa expb -> fun tin ->
 192
 193     let globals = ref [] in
 194     let bigf = {
 195       (* julia's style *)
 196       Visitor_c.default_visitor_c with
 197       Visitor_c.kexpr = (fun (k, bigf) expb ->
 198         match expf expa expb tin with
 199         | [] -> (* failed *) k expb
 200         | xs ->
 201             globals := xs @ !globals;
 202             if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
 203       );
 204       (* pad's style.
 205        * push2 expr globals;  k expr
 206        *  ...
 207        *  !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
 208        * (return false)
 209        *
 210        *)
 211     }
 212     in
 213     Visitor_c.vk_expr bigf expb;
 214     !globals +> List.map (fun ((a, _exp), binding) ->
 215       (a, expb), binding
 216     )
 217
 218   let cocciTy = fun expf expa node -> fun tin ->
 219
 220     let globals = ref [] in
 221     let bigf = {
 222       Visitor_c.default_visitor_c with
 223         Visitor_c.ktype = (fun (k, bigf) expb ->
 224         match expf expa expb tin with
 225         | [] -> (* failed *) k expb
 226         | xs -> globals := xs @ !globals);
 227
 228     }
 229     in
 230     Visitor_c.vk_node bigf node;
 231     !globals +> List.map (fun ((a, _exp), binding) ->
 232       (a, node), binding
 233     )
 234
 235   let cocciInit = fun expf expa node -> fun tin ->
 236
 237     let globals = ref [] in
 238     let bigf = {
 239       Visitor_c.default_visitor_c with
 240         Visitor_c.kini = (fun (k, bigf) expb ->
 241         match expf expa expb tin with
 242         | [] -> (* failed *) k expb
 243         | xs -> globals := xs @ !globals);
 244
 245     }
 246     in
 247     Visitor_c.vk_node bigf node;
 248     !globals +> List.map (fun ((a, _exp), binding) ->
 249       (a, node), binding
 250     )
 251
 252
 253   (* ------------------------------------------------------------------------*)
 254   (* Distribute mcode *)
 255   (* ------------------------------------------------------------------------*)
 256   let tag_mck_pos mck posmck =
 257     match mck with
 258     | Ast_cocci.PLUS c -> Ast_cocci.PLUS c
 259     | Ast_cocci.CONTEXT (pos, xs) ->
 260         assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
 261         Ast_cocci.CONTEXT (posmck, xs)
 262     | Ast_cocci.MINUS (pos, inst, adj, xs) ->
 263         assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
 264         Ast_cocci.MINUS (posmck, inst, adj, xs)
 265
 266
 267   let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
 268     [((x, info, tag_mck_pos mck posmck, pos),stuff), tin.binding]
 269
 270
 271   let distrf (ii_of_x_f) =
 272     fun mcode x -> fun tin ->
 273     let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
 274     in
 275     let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
 276     in
 277     tag_mck_pos_mcode mcode posmck x tin
 278
 279   let distrf_e      = distrf (Lib_parsing_c.ii_of_expr)
 280   let distrf_args   = distrf (Lib_parsing_c.ii_of_args)
 281   let distrf_type   = distrf (Lib_parsing_c.ii_of_type)
 282   let distrf_param  = distrf (Lib_parsing_c.ii_of_param)
 283   let distrf_params = distrf (Lib_parsing_c.ii_of_params)
 284   let distrf_ini    = distrf (Lib_parsing_c.ii_of_ini)
 285   let distrf_inis   = distrf (Lib_parsing_c.ii_of_inis)
 286   let distrf_decl   = distrf (Lib_parsing_c.ii_of_decl)
 287   let distrf_field  = distrf (Lib_parsing_c.ii_of_field)
 288   let distrf_node   = distrf (Lib_parsing_c.ii_of_node)
 289   let distrf_enum_fields = distrf (Lib_parsing_c.ii_of_enum_fields)
 290   let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
 291   let distrf_cst    = distrf (Lib_parsing_c.ii_of_cst)
 292   let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params)
 293
 294
 295   (* ------------------------------------------------------------------------*)
 296   (* Constraints on metavariable values *)
 297   (* ------------------------------------------------------------------------*)
 298   let check_idconstraint matcher c id = fun f tin ->
 299     if matcher c id then
 300       (* success *)
 301       f () tin
 302     else
 303       (* failure *)
 304       fail tin
 305
 306   let check_constraints_ne matcher constraints exp = fun f tin ->
 307     let rec loop = function
 308         [] -> f () tin (* success *)
 309       | c::cs ->
 310           match matcher c exp tin with
 311             [] (* failure *) -> loop cs
 312           | _ (* success *) -> fail tin in
 313     loop constraints
 314
 315   let check_pos_constraints constraints pvalu f tin =
 316     check_constraints_ne
 317       (fun c exp tin ->
 318         let success = [[]] in
 319         let failure = [] in
 320         (* relies on the fact that constraints on pos variables must refer to
 321            inherited variables *)
 322         (match Common.optionise (fun () -> tin.binding0 +> List.assoc c) with
 323           Some valu' ->
 324             if Cocci_vs_c.equal_inh_metavarval exp valu'
 325             then success else failure
 326         | None ->
 327             (* if the variable is not there, it puts no constraints *)
 328             (* not sure this is still useful *)
 329             failure))
 330       constraints pvalu f tin
 331
 332   (* ------------------------------------------------------------------------*)
 333   (* Environment *)
 334   (* ------------------------------------------------------------------------*)
 335   (* pre: if have declared a new metavar that hide another one, then
 336    * must be passed with a binding that deleted this metavar
 337    *
 338    * Here we dont use the keep argument of julia. cf f(X,X), J'ai
 339    * besoin de garder le X en interne, meme si julia s'en fout elle du
 340    * X et qu'elle a mis X a DontSaved.
 341    *)
 342   let check_add_metavars_binding strip _keep inherited = fun (k, valu) tin ->
 343     if inherited
 344     then
 345       match Common.optionise (fun () -> tin.binding0 +> List.assoc k) with
 346       | Some (valu') ->
 347           if Cocci_vs_c.equal_inh_metavarval valu valu'
 348           then Some tin.binding
 349           else None
 350       | None -> None
 351     else
 352       match Common.optionise (fun () -> tin.binding +> List.assoc k) with
 353       | Some (valu') ->
 354           if Cocci_vs_c.equal_metavarval valu valu'
 355           then Some tin.binding
 356           else None
 357
 358       | None ->
 359           let success valu' =
 360             Some (tin.binding +> Common.insert_assoc (k, valu')) in
 361           (match valu with
 362             Ast_c.MetaIdVal (a,c)    ->
 363               (* c is a negated constraint *)
 364               let rec loop = function
 365                   [] -> success(Ast_c.MetaIdVal(a,[]))
 366                 | c::cs ->
 367                     let tmp =
 368                       Common.optionise
 369                         (fun () -> tin.binding0 +> List.assoc c) in
 370                     (match tmp with
 371                       Some (Ast_c.MetaIdVal(v,_)) ->
 372                         if a =$= v
 373                         then None (* failure *)
 374                         else success(Ast_c.MetaIdVal(a,[]))
 375                     | Some _ -> failwith "Not possible"
 376                     | None -> success(Ast_c.MetaIdVal(a,[]))) in
 377               loop c
 378           | Ast_c.MetaFuncVal a      ->
 379               success(Ast_c.MetaFuncVal a)
 380           | Ast_c.MetaLocalFuncVal a ->
 381               success(Ast_c.MetaLocalFuncVal a) (*more?*)
 382           | Ast_c.MetaExprVal (a,c) ->
 383               (* c in the value is only to prepare for the future in which
 384                  we figure out how to have subterm constraints on unbound
 385                  variables.  Now an environment will only contain expression
 386                  values with empty constraints, as all constraints are
 387                  resolved at binding time *)
 388               let stripped =
 389                 if strip
 390                 then Lib_parsing_c.al_expr a
 391                 else Lib_parsing_c.semi_al_expr a in
 392               let inh_stripped = Lib_parsing_c.al_inh_expr a in
 393               let rec loop = function
 394                   [] -> success(Ast_c.MetaExprVal(stripped,[]))
 395                 | c::cs ->
 396                     let tmp =
 397                       Common.optionise
 398                         (fun () -> tin.binding0 +> List.assoc c) in
 399                     (match tmp with
 400                       Some (Ast_c.MetaExprVal(v,_)) ->
 401                         if C_vs_c.subexpression_of_expression inh_stripped v
 402                         then loop cs (* forget satisfied constraints *)
 403                         else None (* failure *)
 404                     | Some _ -> failwith "not possible"
 405                       (* fail if this should be a subterm of something that
 406                          doesn't exist *)
 407                     | None -> None) in
 408               loop c
 409           | Ast_c.MetaExprListVal a ->
 410               success
 411                 (Ast_c.MetaExprListVal
 412                    (if strip
 413                    then Lib_parsing_c.al_arguments a
 414                    else Lib_parsing_c.semi_al_arguments a))
 415
 416           | Ast_c.MetaDeclVal a ->
 417               success
 418                 (Ast_c.MetaDeclVal
 419                    (if strip
 420                    then Lib_parsing_c.al_declaration a
 421                    else Lib_parsing_c.semi_al_declaration a))
 422           | Ast_c.MetaFieldVal a ->
 423               success
 424                 (Ast_c.MetaFieldVal
 425                    (if strip
 426                    then Lib_parsing_c.al_field a
 427                    else Lib_parsing_c.semi_al_field a))
 428           | Ast_c.MetaFieldListVal a ->
 429               success
 430                 (Ast_c.MetaFieldListVal
 431                    (if strip
 432                    then Lib_parsing_c.al_fields a
 433                    else Lib_parsing_c.semi_al_fields a))
 434           | Ast_c.MetaStmtVal a ->
 435               success
 436                 (Ast_c.MetaStmtVal
 437                    (if strip
 438                    then Lib_parsing_c.al_statement a
 439                    else Lib_parsing_c.semi_al_statement a))
 440           | Ast_c.MetaTypeVal a ->
 441               success
 442                 (Ast_c.MetaTypeVal
 443                    (if strip
 444                    then Lib_parsing_c.al_type a
 445                    else Lib_parsing_c.semi_al_type a))
 446
 447           | Ast_c.MetaInitVal a ->
 448               success
 449                 (Ast_c.MetaInitVal
 450                    (if strip
 451                    then Lib_parsing_c.al_init a
 452                    else Lib_parsing_c.semi_al_init a))
 453
 454           | Ast_c.MetaInitListVal a ->
 455               success
 456                 (Ast_c.MetaInitListVal
 457                    (if strip
 458                    then Lib_parsing_c.al_inits a
 459                    else Lib_parsing_c.semi_al_inits a))
 460
 461           | Ast_c.MetaListlenVal a -> success(Ast_c.MetaListlenVal a)
 462
 463           | Ast_c.MetaParamVal a ->
 464               success
 465                 (Ast_c.MetaParamVal
 466                    (if strip
 467                    then Lib_parsing_c.al_param a
 468                    else Lib_parsing_c.semi_al_param a))
 469           | Ast_c.MetaParamListVal a ->
 470               success
 471                 (Ast_c.MetaParamListVal
 472                    (if strip
 473                    then Lib_parsing_c.al_params a
 474                    else Lib_parsing_c.semi_al_params a))
 475
 476           | Ast_c.MetaPosVal (pos1,pos2) ->
 477               success(Ast_c.MetaPosVal (pos1,pos2))
 478           | Ast_c.MetaPosValList l -> success (Ast_c.MetaPosValList l))
 479
 480   let pos_variables tin ia get_pvalu finish =
 481     match Ast_cocci.get_pos_var ia with
 482       [] -> finish tin
 483     | positions ->
 484         let pvalu = Ast_c.MetaPosValList(get_pvalu()) in
 485         let rec loop tin = function
 486             [] -> finish tin
 487           | Ast_cocci.MetaPos(name,constraints,per,keep,inherited) :: rest ->
 488               check_pos_constraints constraints pvalu
 489                 (function () ->
 490             (* constraints are satisfied, now see if we are compatible
 491                with existing bindings *)
 492                   function new_tin ->
 493                     let x = Ast_cocci.unwrap_mcode name in
 494                     let new_binding =
 495                       check_add_metavars_binding false keep inherited
 496                         (x, pvalu) tin in
 497                     (match  new_binding with
 498                       Some binding -> loop {tin with binding = binding} rest
 499                     | None -> fail tin))
 500                 tin in
 501         loop tin positions
 502
 503   let envf keep inherited = fun (k, valu, get_max_min) f tin ->
 504     let x = Ast_cocci.unwrap_mcode k in
 505     match check_add_metavars_binding true keep inherited (x, valu) tin with
 506     | Some binding ->
 507         let new_tin = {tin with binding = binding} in
 508         pos_variables new_tin k
 509           (function _ ->
 510             let (file,current_element,min,max) = get_max_min() in
 511             [(file,current_element,min,max)])
 512           (f ())
 513     | None -> fail tin
 514
 515   (* ------------------------------------------------------------------------*)
 516   (* Environment, allbounds *)
 517   (* ------------------------------------------------------------------------*)
 518   (* all referenced inherited variables have to be bound. This would
 519    * be naturally checked for the minus or context ones in the
 520    * matching process, but have to check the plus ones as well. The
 521    * result of get_inherited contains all of these, but the potential
 522    * redundant checking for the minus and context ones is probably not
 523    * a big deal. If it's a problem, could fix free_vars to distinguish
 524    * between + variables and the other ones. *)
 525
 526   let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
 527     l +> List.for_all (fun inhvar ->
 528       match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with
 529       | Some _ -> true
 530       | None -> false
 531     )
 532
 533   let optional_storage_flag f = fun tin ->
 534     f (tin.extra.optional_storage_iso) tin
 535
 536   let optional_qualifier_flag f = fun tin ->
 537     f (tin.extra.optional_qualifier_iso) tin
 538
 539   let value_format_flag f = fun tin ->
 540     f (tin.extra.value_format_iso) tin
 541
 542   let optional_declarer_semicolon_flag f = fun tin ->
 543     f (tin.extra.optional_declarer_semicolon_iso) tin
 544
 545   (* ------------------------------------------------------------------------*)
 546   (* Tokens *)
 547   (* ------------------------------------------------------------------------*)
 548   let tokenf ia ib = fun tin ->
 549     let pos = Ast_c.info_to_fixpos ib in
 550     let posmck = Ast_cocci.FixPos (pos, pos) in
 551     let finish tin = tag_mck_pos_mcode ia posmck ib tin in
 552     pos_variables tin ia (function _ -> [Lib_parsing_c.lin_col_by_pos [ib]])
 553       finish
 554
 555   let tokenf_mck mck ib = fun tin ->
 556     let pos = Ast_c.info_to_fixpos ib in
 557     let posmck = Ast_cocci.FixPos (pos, pos) in
 558     [(tag_mck_pos mck posmck, ib), tin.binding]
 559
 560 end
 561
 562 (*****************************************************************************)
 563 (* Entry point  *)
 564 (*****************************************************************************)
 565 module MATCH  = Cocci_vs_c.COCCI_VS_C (XMATCH)
 566
 567
 568 let match_re_node2 dropped_isos a b binding0 =
 569
 570   let tin = {
 571     XMATCH.extra = {
 572       optional_storage_iso   = not(List.mem "optional_storage"   dropped_isos);
 573       optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
 574       value_format_iso       = not(List.mem "value_format"       dropped_isos);
 575       optional_declarer_semicolon_iso =
 576         not(List.mem "optional_declarer_semicolon"   dropped_isos);
 577     };
 578     XMATCH.binding = [];
 579     XMATCH.binding0 = binding0;
 580   } in
 581
 582   MATCH.rule_elem_node a b tin
 583   (* take only the tagged-SP, the 'a' *)
 584   +> List.map (fun ((a,_b), binding) -> a, binding)
 585
 586
 587 let match_re_node a b c d =
 588   Common.profile_code "Pattern3.match_re_node"
 589     (fun () -> match_re_node2 a b c d)