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