engine/pattern_c.ml

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