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