(*
+ * Copyright 2010, INRIA, University of Copenhagen
+ * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
* This file is part of Coccinelle.
*)
-(* Yoann Padioleau
- *
- * Copyright (C) 2006, 2007 Ecole des Mines de Nantes
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License (GPL)
- * version 2 as published by the Free Software Foundation.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * file license.txt for more details.
- *
- * This file was part of Coccinelle.
- *)
open Common
module Flag_engine = Flag_matcher
(*****************************************************************************)
-(* The functor argument *)
+(* The functor argument *)
(*****************************************************************************)
(* info passed recursively in monad in addition to binding *)
-type xinfo = {
+type xinfo = {
optional_storage_iso : bool;
optional_qualifier_iso : bool;
value_format_iso : bool;
module XMATCH = struct
(* ------------------------------------------------------------------------*)
- (* Combinators history *)
+ (* Combinators history *)
(* ------------------------------------------------------------------------*)
(*
- * version0:
+ * version0:
* type ('a, 'b) matcher = 'a -> 'b -> bool
*
* version1: same but with a global variable holding the current binding
* BUT bug
* - can have multiple possibilities
* - globals sux
- * - sometimes have to undo, cos if start match, then it binds,
+ * - sometimes have to undo, cos if start match, then it binds,
* and if later it does not match, then must undo the first binds.
- * ex: when match parameters, can try to match, but then we found far
+ * ex: when match parameters, can try to match, but then we found far
* later that the last argument of a function does not match
* => have to uando the binding !!!
- * (can handle that too with a global, by saving the
+ * (can handle that too with a global, by saving the
* global, ... but sux)
* => better not use global
- *
- * version2:
+ *
+ * version2:
* type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
*
* Empty list mean failure (let matchfailure = []).
- * To be able to have pretty code, have to use partial application
+ * To be able to have pretty code, have to use partial application
* powa, and so the type is in fact
*
* version3:
*
* Then by defining the correct combinators, can have quite pretty code (that
* looks like the clean code of version0).
- *
+ *
* opti: return a lazy list of possible matchs ?
- *
+ *
* version4: type tin = Lib_engine.metavars_binding
*)
(* ------------------------------------------------------------------------*)
- (* Standard type and operators *)
+ (* Standard type and operators *)
(* ------------------------------------------------------------------------*)
- type tin = {
+ type tin = {
extra: xinfo;
binding: Lib_engine.metavars_binding;
binding0: Lib_engine.metavars_binding; (* inherited bindings *)
}
(* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
(* opti? use set instead of list *)
- type 'x tout = ('x * Lib_engine.metavars_binding) list
+ type 'x tout = ('x * Lib_engine.metavars_binding) list
type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
(* was >&&> *)
let (>>=) m1 m2 = fun tin ->
let xs = m1 tin in
- let xxs = xs +> List.map (fun ((a,b), binding) ->
+ let xxs = xs +> List.map (fun ((a,b), binding) ->
m2 a b {tin with binding = binding}
) in
List.flatten xxs
(* Je compare les bindings retournés par les differentes branches.
* Si la deuxieme branche amene a des bindings qui sont deja presents
* dans la premiere branche, alors je ne les accepte pas.
- *
+ *
* update: still useful now that julia better handle Exp directly via
* ctl tricks using positions ?
*)
- let (>|+|>) m1 m2 = fun tin ->
+ let (>|+|>) m1 m2 = fun tin ->
(* CHOICE
let xs = m1 tin in
if null xs
let res1 = m1 tin in
let res2 = m2 tin in
let list_bindings_already = List.map snd res1 in
- res1 ++
- (res2 +> List.filter (fun (x, binding) ->
- not
- (list_bindings_already +> List.exists (fun already ->
+ res1 ++
+ (res2 +> List.filter (fun (x, binding) ->
+ not
+ (list_bindings_already +> List.exists (fun already ->
Lib_engine.equal_binding binding already))
))
-
-
-
+
+
+
let (>||>) m1 m2 = fun tin ->
(* CHOICE
let xs = m1 tin in
if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
- let return res = fun tin ->
+ let return res = fun tin ->
[res, tin.binding]
- let fail = fun tin ->
+ let fail = fun tin ->
[]
- let (>&&>) f m = fun tin ->
+ let (>&&>) f m = fun tin ->
if f tin
then m tin
else fail tin
let mode = Cocci_vs_c.PatternMode
(* ------------------------------------------------------------------------*)
- (* Exp *)
+ (* Exp *)
(* ------------------------------------------------------------------------*)
- let cocciExp = fun expf expa node -> fun tin ->
+ let cocciExp = fun expf expa node -> fun tin ->
let globals = ref [] in
- let bigf = {
+ let bigf = {
(* julia's style *)
- Visitor_c.default_visitor_c with
+ Visitor_c.default_visitor_c with
Visitor_c.kexpr = (fun (k, bigf) expb ->
match expf expa expb tin with
| [] -> (* failed *) k expb
- | xs ->
- globals := xs @ !globals;
+ | xs ->
+ globals := xs @ !globals;
if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
);
(* pad's style.
* push2 expr globals; k expr
* ...
- * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
+ * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
* (return false)
- *
+ *
*)
}
in
Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
+ !globals +> List.map (fun ((a, _exp), binding) ->
(a, node), binding
)
(* same as cocciExp, but for expressions in an expression, not expressions
in a node *)
- let cocciExpExp = fun expf expa expb -> fun tin ->
+ let cocciExpExp = fun expf expa expb -> fun tin ->
let globals = ref [] in
- let bigf = {
+ let bigf = {
(* julia's style *)
- Visitor_c.default_visitor_c with
+ Visitor_c.default_visitor_c with
Visitor_c.kexpr = (fun (k, bigf) expb ->
match expf expa expb tin with
| [] -> (* failed *) k expb
- | xs ->
- globals := xs @ !globals;
+ | xs ->
+ globals := xs @ !globals;
if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
);
(* pad's style.
* push2 expr globals; k expr
* ...
- * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
+ * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
* (return false)
- *
+ *
*)
}
in
Visitor_c.vk_expr bigf expb;
- !globals +> List.map (fun ((a, _exp), binding) ->
+ !globals +> List.map (fun ((a, _exp), binding) ->
(a, expb), binding
)
- let cocciTy = fun expf expa node -> fun tin ->
+ let cocciTy = fun expf expa node -> fun tin ->
let globals = ref [] in
- let bigf = {
- Visitor_c.default_visitor_c with
- Visitor_c.ktype = (fun (k, bigf) expb ->
+ let bigf = {
+ Visitor_c.default_visitor_c with
+ Visitor_c.ktype = (fun (k, bigf) expb ->
match expf expa expb tin with
| [] -> (* failed *) k expb
| xs -> globals := xs @ !globals);
- }
+ }
in
Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
+ !globals +> List.map (fun ((a, _exp), binding) ->
(a, node), binding
)
- let cocciInit = fun expf expa node -> fun tin ->
+ let cocciInit = fun expf expa node -> fun tin ->
let globals = ref [] in
- let bigf = {
- Visitor_c.default_visitor_c with
- Visitor_c.kini = (fun (k, bigf) expb ->
+ let bigf = {
+ Visitor_c.default_visitor_c with
+ Visitor_c.kini = (fun (k, bigf) expb ->
match expf expa expb tin with
| [] -> (* failed *) k expb
| xs -> globals := xs @ !globals);
- }
+ }
in
Visitor_c.vk_node bigf node;
- !globals +> List.map (fun ((a, _exp), binding) ->
+ !globals +> List.map (fun ((a, _exp), binding) ->
(a, node), binding
)
(* ------------------------------------------------------------------------*)
- (* Distribute mcode *)
+ (* Distribute mcode *)
(* ------------------------------------------------------------------------*)
let tag_mck_pos mck posmck =
- match mck with
+ match mck with
| Ast_cocci.PLUS c -> Ast_cocci.PLUS c
- | Ast_cocci.CONTEXT (pos, xs) ->
+ | Ast_cocci.CONTEXT (pos, xs) ->
assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
Ast_cocci.CONTEXT (posmck, xs)
- | Ast_cocci.MINUS (pos, inst, adj, xs) ->
+ | Ast_cocci.MINUS (pos, inst, adj, xs) ->
assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
Ast_cocci.MINUS (posmck, inst, adj, xs)
-
- let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
+
+ let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
[((x, info, tag_mck_pos mck posmck, pos),stuff), tin.binding]
-
+
let distrf (ii_of_x_f) =
- fun mcode x -> fun tin ->
+ fun mcode x -> fun tin ->
let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
in
- let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
+ let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
in
tag_mck_pos_mcode mcode posmck x tin
- let distrf_e = distrf (Lib_parsing_c.ii_of_expr)
- let distrf_args = distrf (Lib_parsing_c.ii_of_args)
- let distrf_type = distrf (Lib_parsing_c.ii_of_type)
- let distrf_param = distrf (Lib_parsing_c.ii_of_param)
+ let distrf_e = distrf (Lib_parsing_c.ii_of_expr)
+ let distrf_args = distrf (Lib_parsing_c.ii_of_args)
+ let distrf_type = distrf (Lib_parsing_c.ii_of_type)
+ let distrf_param = distrf (Lib_parsing_c.ii_of_param)
let distrf_params = distrf (Lib_parsing_c.ii_of_params)
- let distrf_ini = distrf (Lib_parsing_c.ii_of_ini)
+ let distrf_ini = distrf (Lib_parsing_c.ii_of_ini)
+ let distrf_inis = distrf (Lib_parsing_c.ii_of_inis)
+ let distrf_decl = distrf (Lib_parsing_c.ii_of_decl)
+ let distrf_field = distrf (Lib_parsing_c.ii_of_field)
let distrf_node = distrf (Lib_parsing_c.ii_of_node)
- let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
- let distrf_cst = distrf (Lib_parsing_c.ii_of_cst)
+ let distrf_enum_fields = distrf (Lib_parsing_c.ii_of_enum_fields)
+ let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
+ let distrf_cst = distrf (Lib_parsing_c.ii_of_cst)
let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params)
constraints pvalu f tin
(* ------------------------------------------------------------------------*)
- (* Environment *)
+ (* Environment *)
(* ------------------------------------------------------------------------*)
(* pre: if have declared a new metavar that hide another one, then
* must be passed with a binding that deleted this metavar
- *
+ *
* Here we dont use the keep argument of julia. cf f(X,X), J'ai
* besoin de garder le X en interne, meme si julia s'en fout elle du
* X et qu'elle a mis X a DontSaved.
if Cocci_vs_c.equal_metavarval valu valu'
then Some tin.binding
else None
-
+
| None ->
- let valu' =
- match valu with
- Ast_c.MetaIdVal a -> Ast_c.MetaIdVal a
- | Ast_c.MetaFuncVal a -> Ast_c.MetaFuncVal a
- | Ast_c.MetaLocalFuncVal a -> Ast_c.MetaLocalFuncVal a (*more?*)
- | Ast_c.MetaExprVal a ->
- Ast_c.MetaExprVal
- (if strip
- then Lib_parsing_c.al_expr a
- else Lib_parsing_c.semi_al_expr a)
- | Ast_c.MetaExprListVal a ->
- Ast_c.MetaExprListVal
- (if strip
- then Lib_parsing_c.al_arguments a
- else Lib_parsing_c.semi_al_arguments a)
-
- | Ast_c.MetaStmtVal a ->
- Ast_c.MetaStmtVal
- (if strip
- then Lib_parsing_c.al_statement a
- else Lib_parsing_c.semi_al_statement a)
- | Ast_c.MetaTypeVal a ->
- Ast_c.MetaTypeVal
- (if strip
- then Lib_parsing_c.al_type a
- else Lib_parsing_c.semi_al_type a)
-
- | Ast_c.MetaInitVal a ->
- Ast_c.MetaInitVal
- (if strip
- then Lib_parsing_c.al_init a
- else Lib_parsing_c.semi_al_init a)
-
- | Ast_c.MetaListlenVal a -> Ast_c.MetaListlenVal a
-
- | Ast_c.MetaParamVal a -> failwith "not handling MetaParamVal"
- | Ast_c.MetaParamListVal a ->
- Ast_c.MetaParamListVal
- (if strip
- then Lib_parsing_c.al_params a
- else Lib_parsing_c.semi_al_params a)
-
- | Ast_c.MetaPosVal (pos1,pos2) -> Ast_c.MetaPosVal (pos1,pos2)
- | Ast_c.MetaPosValList l -> Ast_c.MetaPosValList l
- in Some (tin.binding +> Common.insert_assoc (k, valu'))
+ let success valu' =
+ Some (tin.binding +> Common.insert_assoc (k, valu')) in
+ (match valu with
+ Ast_c.MetaIdVal (a,c) ->
+ (* c is a negated constraint *)
+ let rec loop = function
+ [] -> success(Ast_c.MetaIdVal(a,[]))
+ | c::cs ->
+ let tmp =
+ Common.optionise
+ (fun () -> tin.binding0 +> List.assoc c) in
+ (match tmp with
+ Some (Ast_c.MetaIdVal(v,_)) ->
+ if a =$= v
+ then None (* failure *)
+ else success(Ast_c.MetaIdVal(a,[]))
+ | Some _ -> failwith "Not possible"
+ | None -> success(Ast_c.MetaIdVal(a,[]))) in
+ loop c
+ | Ast_c.MetaFuncVal a ->
+ success(Ast_c.MetaFuncVal a)
+ | Ast_c.MetaLocalFuncVal a ->
+ success(Ast_c.MetaLocalFuncVal a) (*more?*)
+ | Ast_c.MetaExprVal (a,c) ->
+ (* c in the value is only to prepare for the future in which
+ we figure out how to have subterm constraints on unbound
+ variables. Now an environment will only contain expression
+ values with empty constraints, as all constraints are
+ resolved at binding time *)
+ let stripped =
+ if strip
+ then Lib_parsing_c.al_expr a
+ else Lib_parsing_c.semi_al_expr a in
+ let inh_stripped = Lib_parsing_c.al_inh_expr a in
+ let rec loop = function
+ [] -> success(Ast_c.MetaExprVal(stripped,[]))
+ | c::cs ->
+ let tmp =
+ Common.optionise
+ (fun () -> tin.binding0 +> List.assoc c) in
+ (match tmp with
+ Some (Ast_c.MetaExprVal(v,_)) ->
+ if C_vs_c.subexpression_of_expression inh_stripped v
+ then loop cs (* forget satisfied constraints *)
+ else None (* failure *)
+ | Some _ -> failwith "not possible"
+ (* fail if this should be a subterm of something that
+ doesn't exist *)
+ | None -> None) in
+ loop c
+ | Ast_c.MetaExprListVal a ->
+ success
+ (Ast_c.MetaExprListVal
+ (if strip
+ then Lib_parsing_c.al_arguments a
+ else Lib_parsing_c.semi_al_arguments a))
+
+ | Ast_c.MetaDeclVal a ->
+ success
+ (Ast_c.MetaDeclVal
+ (if strip
+ then Lib_parsing_c.al_declaration a
+ else Lib_parsing_c.semi_al_declaration a))
+ | Ast_c.MetaFieldVal a ->
+ success
+ (Ast_c.MetaFieldVal
+ (if strip
+ then Lib_parsing_c.al_field a
+ else Lib_parsing_c.semi_al_field a))
+ | Ast_c.MetaStmtVal a ->
+ success
+ (Ast_c.MetaStmtVal
+ (if strip
+ then Lib_parsing_c.al_statement a
+ else Lib_parsing_c.semi_al_statement a))
+ | Ast_c.MetaTypeVal a ->
+ success
+ (Ast_c.MetaTypeVal
+ (if strip
+ then Lib_parsing_c.al_type a
+ else Lib_parsing_c.semi_al_type a))
+
+ | Ast_c.MetaInitVal a ->
+ success
+ (Ast_c.MetaInitVal
+ (if strip
+ then Lib_parsing_c.al_init a
+ else Lib_parsing_c.semi_al_init a))
+
+ | Ast_c.MetaListlenVal a -> success(Ast_c.MetaListlenVal a)
+
+ | Ast_c.MetaParamVal a ->
+ success
+ (Ast_c.MetaParamVal
+ (if strip
+ then Lib_parsing_c.al_param a
+ else Lib_parsing_c.semi_al_param a))
+ | Ast_c.MetaParamListVal a ->
+ success
+ (Ast_c.MetaParamListVal
+ (if strip
+ then Lib_parsing_c.al_params a
+ else Lib_parsing_c.semi_al_params a))
+
+ | Ast_c.MetaPosVal (pos1,pos2) ->
+ success(Ast_c.MetaPosVal (pos1,pos2))
+ | Ast_c.MetaPosValList l -> success (Ast_c.MetaPosValList l))
let envf keep inherited = fun (k, valu, get_max_min) f tin ->
let x = Ast_cocci.unwrap_mcode k in
| None -> fail tin
(* ------------------------------------------------------------------------*)
- (* Environment, allbounds *)
+ (* Environment, allbounds *)
(* ------------------------------------------------------------------------*)
(* all referenced inherited variables have to be bound. This would
* be naturally checked for the minus or context ones in the
* between + variables and the other ones. *)
let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
- l +> List.for_all (fun inhvar ->
+ l +> List.for_all (fun inhvar ->
match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with
| Some _ -> true
| None -> false
)
- let optional_storage_flag f = fun tin ->
+ let optional_storage_flag f = fun tin ->
f (tin.extra.optional_storage_iso) tin
- let optional_qualifier_flag f = fun tin ->
+ let optional_qualifier_flag f = fun tin ->
f (tin.extra.optional_qualifier_iso) tin
- let value_format_flag f = fun tin ->
+ let value_format_flag f = fun tin ->
f (tin.extra.value_format_iso) tin
-
(* ------------------------------------------------------------------------*)
- (* Tokens *)
+ (* Tokens *)
(* ------------------------------------------------------------------------*)
let tokenf ia ib = fun tin ->
let pos = Ast_c.info_to_fixpos ib in
tin
| _ -> finish tin
- let tokenf_mck mck ib = fun tin ->
+ let tokenf_mck mck ib = fun tin ->
let pos = Ast_c.info_to_fixpos ib in
let posmck = Ast_cocci.FixPos (pos, pos) in
[(tag_mck_pos mck posmck, ib), tin.binding]
-
+
end
(*****************************************************************************)
-(* Entry point *)
+(* Entry point *)
(*****************************************************************************)
module MATCH = Cocci_vs_c.COCCI_VS_C (XMATCH)
-let match_re_node2 dropped_isos a b binding0 =
+let match_re_node2 dropped_isos a b binding0 =
- let tin = {
+ let tin = {
XMATCH.extra = {
optional_storage_iso = not(List.mem "optional_storage" dropped_isos);
optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
+> List.map (fun ((a,_b), binding) -> a, binding)
-let match_re_node a b c d =
- Common.profile_code "Pattern3.match_re_node"
+let match_re_node a b c d =
+ Common.profile_code "Pattern3.match_re_node"
(fun () -> match_re_node2 a b c d)
HCoop / bpt / coccinelle.git / blobdiff