engine/pattern_c.ml

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