[bpt/coccinelle.git] / engine / asttomember.ml

(*
* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
* This file is part of Coccinelle.
* 
* Coccinelle is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, according to version 2 of the License.
* 
* Coccinelle 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
* GNU General Public License for more details.
* 
* You should have received a copy of the GNU General Public License
* along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
* 
* The authors reserve the right to distribute this or future versions of
* Coccinelle under other licenses.
*)


(* on the first pass, onlyModif is true, so we don't see all matched nodes,
only modified ones *)

module Ast = Ast_cocci
module V = Visitor_ast
module CTL = Ast_ctl

let mcode r (_,_,kind,_) =
  match kind with
    Ast.MINUS(_,_,_,_) -> true
  | Ast.PLUS -> failwith "not possible"
  | Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING)

let no_mcode _ _ = false

let contains_modif used_after x =
  if List.exists (function x -> List.mem x used_after) (Ast.get_fvs x)
  then true
  else
    let bind x y = x or y in
    let option_default = false in
    let do_nothing r k e = k e in
    let rule_elem r k re =
      let res = k re in
      match Ast.unwrap re with
	Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) ->
	  bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
      | Ast.Decl(bef,_,decl) ->
	  bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
      | _ -> res in
    let recursor =
      V.combiner bind option_default
	mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
	mcode
	do_nothing do_nothing do_nothing do_nothing
	do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
	do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in
    recursor.V.combiner_rule_elem x

(* contains an inherited metavariable or contains a constant *)
let contains_constant x =
  match Ast.get_inherited x with
    [] ->
      let bind x y = x or y in
      let option_default = false in
      let do_nothing r k e = k e in
      let mcode _ _ = false in
      let ident r k i =
	match Ast.unwrap i with
	  Ast.Id(name) -> true
	| _ -> k i in
      let expr r k e =
	match Ast.unwrap e with
	  Ast.Constant(const) -> true
	| _ -> k e in
      let recursor =
	V.combiner bind option_default
	  mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
	  mcode
	  do_nothing do_nothing do_nothing do_nothing
	  ident expr do_nothing do_nothing do_nothing do_nothing
	  do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing in
      recursor.V.combiner_rule_elem x
  | _ -> true

(* --------------------------------------------------------------------- *)

let print_info = function
    [] -> Printf.printf "no information\n"
  | l ->
      List.iter
	(function disj ->
	  Printf.printf "one set of required things %d:\n"
	    (List.length disj);
	  List.iter
	    (function (_,thing) ->
	      Printf.printf "%s\n"
		(Pretty_print_cocci.rule_elem_to_string thing))
	    disj;)
	l

(* --------------------------------------------------------------------- *)

(* drop all distinguishing information from a term *)
let strip =
  let do_nothing r k e = Ast.make_term (Ast.unwrap (k e)) in
  let do_absolutely_nothing r k e = k e in
  let mcode m = Ast.make_mcode(Ast.unwrap_mcode m) in
  let rule_elem r k re =
    let res = do_nothing r k re in
    let no_mcode = Ast.CONTEXT(Ast.NoPos,Ast.NOTHING) in
    match Ast.unwrap res with
      Ast.FunHeader(bef,b,fninfo,name,lp,params,rp) ->
	Ast.rewrap res
	  (Ast.FunHeader(no_mcode,b,fninfo,name,lp,params,rp))
    | Ast.Decl(bef,b,decl) -> Ast.rewrap res (Ast.Decl(no_mcode,b,decl))
    | _ -> res in
  let recursor =
    V.rebuilder
      mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
      do_nothing do_nothing do_nothing do_nothing
      do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
      do_nothing rule_elem do_nothing do_nothing
      do_nothing do_absolutely_nothing in
  recursor.V.rebuilder_rule_elem

(* --------------------------------------------------------------------- *)

let disj l1 l2 = l1 l2

let rec conj xs ys =
  match (xs,ys) with
    ([],_) -> ys
  | (_,[]) -> xs
  | _ ->
      List.fold_left
	(function prev ->
	  function x ->
	    List.fold_left
	      (function prev ->
		function cur ->
		  let cur_res = (List.sort compare (Common.union_set x cur)) in
		  cur_res ::
		  (List.filter
		     (function x -> not (Common.include_set cur_res x))
		     prev))
	      prev ys)
	[] xs

let conj_wrapped x l = conj [List.map (function x -> (1,strip x)) x] l

(* --------------------------------------------------------------------- *)
(* the main translation loop *)

let rule_elem re =
  match Ast.unwrap re with
    Ast.DisjRuleElem(res) -> [[(List.length res,strip re)]]
  | _ -> [[(1,strip re)]]

let conj_one testfn x l =
  if testfn x
  then conj (rule_elem x) l
  else l

let rec statement_list testfn mcode tail stmt_list : 'a list list =
  match Ast.unwrap stmt_list with
    Ast.DOTS(x) | Ast.CIRCLES(x) | Ast.STARS(x) ->
      (match List.rev x with
	[] -> []
      |	last::rest ->
	  List.fold_right
	    (function cur ->
	      function rest ->
		conj (statement testfn mcode false cur) rest)
	    rest (statement testfn mcode tail last))

and statement testfn mcode tail stmt : 'a list list =
  match Ast.unwrap stmt with
    Ast.Atomic(ast) ->
      (match Ast.unwrap ast with
	(* modifications on return are managed in some other way *)
	Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) when tail -> []
      |	_ -> if testfn ast then rule_elem ast else [])
  | Ast.Seq(lbrace,body,rbrace) ->
      let body_info = statement_list testfn mcode tail body in
      if testfn lbrace or testfn rbrace
      then conj_wrapped [lbrace;rbrace] body_info
      else body_info

  | Ast.IfThen(header,branch,(_,_,_,aft))
  | Ast.While(header,branch,(_,_,_,aft))
  | Ast.For(header,branch,(_,_,_,aft))
  | Ast.Iterator(header,branch,(_,_,_,aft)) ->
      if testfn header or mcode () ((),(),aft,Ast.NoMetaPos)
      then conj (rule_elem header) (statement testfn mcode tail branch)
      else statement testfn mcode tail branch

  | Ast.Switch(header,lb,cases,rb) ->
      let body_info = case_lines  testfn mcode tail cases in
      if testfn header or testfn lb or testfn rb
      then conj (rule_elem header) body_info
      else body_info

  | Ast.IfThenElse(ifheader,branch1,els,branch2,(_,_,_,aft)) ->
      let branches =
	conj
	  (statement testfn mcode tail branch1)
	  (statement testfn mcode tail branch2) in
      if testfn ifheader or mcode () ((),(),aft,Ast.NoMetaPos)
      then conj (rule_elem ifheader) branches
      else branches

  | Ast.Disj(stmt_dots_list) ->
      let processed =
	List.map (statement_list testfn mcode tail) stmt_dots_list in
      (* if one branch gives no information, then we have to take anything *)
      if List.exists (function [] -> true | _ -> false) processed
      then []
      else Common.union_all processed

  | Ast.Nest(stmt_dots,whencode,true,_,_) ->
      statement_list testfn mcode false stmt_dots

  | Ast.Nest(stmt_dots,whencode,false,_,_) -> []

  | Ast.Dots(_,whencodes,_,_) -> []

  | Ast.FunDecl(header,lbrace,body,rbrace) ->
      let body_info = statement_list testfn mcode true body in
      if testfn header or testfn lbrace or testfn rbrace
      then conj (rule_elem header) body_info
      else body_info

  | Ast.Define(header,body) ->
      conj_one testfn header (statement_list testfn mcode tail body)

  | Ast.OptStm(stm) -> []

  | Ast.UniqueStm(stm) -> statement testfn mcode tail stm

  | _ -> failwith "not supported"

and case_lines testfn mcode tail cases =
  match cases with
    [] -> []
  | last::rest ->
      List.fold_right
	(function cur ->
	  function rest ->
	    conj (case_line testfn mcode false cur) rest)
	rest (case_line testfn mcode tail last)

and case_line testfn mcode tail case =
  match Ast.unwrap case with
    Ast.CaseLine(header,code) ->
      conj_one testfn header (statement_list testfn mcode tail code)
	  
  | Ast.OptCase(case) -> []

(* --------------------------------------------------------------------- *)
(* Function declaration *)

let top_level testfn mcode t : 'a list list =
  match Ast.unwrap t with
    Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
  | Ast.DECL(stmt) -> statement testfn mcode false stmt
  | Ast.CODE(stmt_dots) -> statement_list testfn mcode false stmt_dots
  | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords"

(* --------------------------------------------------------------------- *)
(* Entry points *)

let debug = false

(* if we end up with nothing, we assume that this rule is only here because
someone depends on it, and thus we try again with testfn as contains_modif.
Alternatively, we could check that this rule is mentioned in some
dependency, but that would be a little more work, and doesn't seem
worthwhile. *)

(* lists are sorted such that smaller DisjRuleElem are first, because they
are cheaper to test *)

let asttomemberz (_,_,l) used_after =
  let process_one (l : (int * Ast_cocci.rule_elem) list list) =
    if debug
    then print_info l;
    List.map
      (function info ->
        let info =
          List.sort (function (n1,_) -> function (n2,_) -> compare n1 n2)
            info in
        List.map (function (_,x) -> (Lib_engine.Match(x),CTL.Control)) info)
      l in
  List.map2
    (function min -> function (max,big_max) ->
      match min with
        [] ->
          (match max() with
            [] -> process_one (big_max())
          | max -> process_one max)
      | _ -> process_one min)
    (List.map (top_level contains_constant no_mcode) l)
    (List.combine
        (List.map2
           (function x -> function ua -> function _ ->
             top_level (contains_modif ua) mcode x)
           l used_after)
        (List.map
           (function x -> function _ ->
             top_level (function _ -> true) no_mcode x)
           l))

let asttomember r used_after =
  match r with
    Ast.ScriptRule _ | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
  | Ast.CocciRule (a,b,c,_,_) -> asttomemberz (a,b,c) used_after
Commit	Line	Data
34e49164	1	(*
faf9a90c	2	* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
34e49164 C	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
	22
	23	(* on the first pass, onlyModif is true, so we don't see all matched nodes,
	24	only modified ones *)
	25
	26	module Ast = Ast_cocci
	27	module V = Visitor_ast
	28	module CTL = Ast_ctl
	29
	30	let mcode r (_,_,kind,_) =
	31	match kind with
708f4980	32	Ast.MINUS(_,_,_,_) -> true
34e49164 C	33	\| Ast.PLUS -> failwith "not possible"
	34	\| Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING)
	35
	36	let no_mcode _ _ = false
	37
	38	let contains_modif used_after x =
	39	if List.exists (function x -> List.mem x used_after) (Ast.get_fvs x)
	40	then true
	41	else
	42	let bind x y = x or y in
	43	let option_default = false in
	44	let do_nothing r k e = k e in
	45	let rule_elem r k re =
	46	let res = k re in
	47	match Ast.unwrap re with
	48	Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) ->
	49	bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
	50	\| Ast.Decl(bef,_,decl) ->
	51	bind (mcode r ((),(),bef,Ast.NoMetaPos)) res
	52	\| _ -> res in
	53	let recursor =
	54	V.combiner bind option_default
	55	mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
faf9a90c	56	mcode
34e49164 C	57	do_nothing do_nothing do_nothing do_nothing
	58	do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
	59	do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in
	60	recursor.V.combiner_rule_elem x
	61
	62	(* contains an inherited metavariable or contains a constant *)
	63	let contains_constant x =
	64	match Ast.get_inherited x with
	65	[] ->
	66	let bind x y = x or y in
	67	let option_default = false in
	68	let do_nothing r k e = k e in
	69	let mcode _ _ = false in
	70	let ident r k i =
	71	match Ast.unwrap i with
	72	Ast.Id(name) -> true
	73	\| _ -> k i in
	74	let expr r k e =
	75	match Ast.unwrap e with
	76	Ast.Constant(const) -> true
	77	\| _ -> k e in
	78	let recursor =
	79	V.combiner bind option_default
	80	mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
faf9a90c	81	mcode
34e49164 C	82	do_nothing do_nothing do_nothing do_nothing
	83	ident expr do_nothing do_nothing do_nothing do_nothing
	84	do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing in
	85	recursor.V.combiner_rule_elem x
	86	\| _ -> true
	87
	88	(* --------------------------------------------------------------------- *)
	89
	90	let print_info = function
	91	[] -> Printf.printf "no information\n"
	92	\| l ->
	93	List.iter
	94	(function disj ->
	95	Printf.printf "one set of required things %d:\n"
	96	(List.length disj);
	97	List.iter
	98	(function (_,thing) ->
	99	Printf.printf "%s\n"
	100	(Pretty_print_cocci.rule_elem_to_string thing))
	101	disj;)
	102	l
	103
	104	(* --------------------------------------------------------------------- *)
	105
	106	(* drop all distinguishing information from a term *)
	107	let strip =
	108	let do_nothing r k e = Ast.make_term (Ast.unwrap (k e)) in
	109	let do_absolutely_nothing r k e = k e in
	110	let mcode m = Ast.make_mcode(Ast.unwrap_mcode m) in
	111	let rule_elem r k re =
	112	let res = do_nothing r k re in
	113	let no_mcode = Ast.CONTEXT(Ast.NoPos,Ast.NOTHING) in
	114	match Ast.unwrap res with
	115	Ast.FunHeader(bef,b,fninfo,name,lp,params,rp) ->
	116	Ast.rewrap res
	117	(Ast.FunHeader(no_mcode,b,fninfo,name,lp,params,rp))
	118	\| Ast.Decl(bef,b,decl) -> Ast.rewrap res (Ast.Decl(no_mcode,b,decl))
	119	\| _ -> res in
	120	let recursor =
	121	V.rebuilder
	122	mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
34e49164 C	123	do_nothing do_nothing do_nothing do_nothing
	124	do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
	125	do_nothing rule_elem do_nothing do_nothing
	126	do_nothing do_absolutely_nothing in
	127	recursor.V.rebuilder_rule_elem
	128
	129	(* --------------------------------------------------------------------- *)
	130
	131	let disj l1 l2 = l1 l2
	132
	133	let rec conj xs ys =
	134	match (xs,ys) with
	135	([],_) -> ys
	136	\| (_,[]) -> xs
	137	\| _ ->
	138	List.fold_left
	139	(function prev ->
	140	function x ->
	141	List.fold_left
	142	(function prev ->
	143	function cur ->
	144	let cur_res = (List.sort compare (Common.union_set x cur)) in
	145	cur_res ::
	146	(List.filter
	147	(function x -> not (Common.include_set cur_res x))
	148	prev))
	149	prev ys)
	150	[] xs
	151
	152	let conj_wrapped x l = conj [List.map (function x -> (1,strip x)) x] l
	153
	154	(* --------------------------------------------------------------------- *)
	155	(* the main translation loop *)
	156
	157	let rule_elem re =
	158	match Ast.unwrap re with
	159	Ast.DisjRuleElem(res) -> [[(List.length res,strip re)]]
	160	\| _ -> [[(1,strip re)]]
	161
	162	let conj_one testfn x l =
	163	if testfn x
	164	then conj (rule_elem x) l
	165	else l
	166
	167	let rec statement_list testfn mcode tail stmt_list : 'a list list =
	168	match Ast.unwrap stmt_list with
	169	Ast.DOTS(x) \| Ast.CIRCLES(x) \| Ast.STARS(x) ->
	170	(match List.rev x with
	171	[] -> []
	172	\| last::rest ->
	173	List.fold_right
	174	(function cur ->
	175	function rest ->
	176	conj (statement testfn mcode false cur) rest)
	177	rest (statement testfn mcode tail last))
	178
	179	and statement testfn mcode tail stmt : 'a list list =
	180	match Ast.unwrap stmt with
	181	Ast.Atomic(ast) ->
	182	(match Ast.unwrap ast with
	183	(* modifications on return are managed in some other way *)
	184	Ast.Return(_,_) \| Ast.ReturnExpr(_,_,_) when tail -> []
	185	\| _ -> if testfn ast then rule_elem ast else [])
708f4980 C	186	\| Ast.Seq(lbrace,body,rbrace) ->
708f4980 C	187	let body_info = statement_list testfn mcode tail body in
34e49164 C	188	if testfn lbrace or testfn rbrace
	189	then conj_wrapped [lbrace;rbrace] body_info
	190	else body_info
	191
	192	\| Ast.IfThen(header,branch,(_,_,_,aft))
	193	\| Ast.While(header,branch,(_,_,_,aft))
	194	\| Ast.For(header,branch,(_,_,_,aft))
	195	\| Ast.Iterator(header,branch,(_,_,_,aft)) ->
	196	if testfn header or mcode () ((),(),aft,Ast.NoMetaPos)
	197	then conj (rule_elem header) (statement testfn mcode tail branch)
	198	else statement testfn mcode tail branch
	199
	200	\| Ast.Switch(header,lb,cases,rb) ->
	201	let body_info = case_lines testfn mcode tail cases in
	202	if testfn header or testfn lb or testfn rb
	203	then conj (rule_elem header) body_info
	204	else body_info
	205
	206	\| Ast.IfThenElse(ifheader,branch1,els,branch2,(_,_,_,aft)) ->
	207	let branches =
	208	conj
	209	(statement testfn mcode tail branch1)
	210	(statement testfn mcode tail branch2) in
	211	if testfn ifheader or mcode () ((),(),aft,Ast.NoMetaPos)
	212	then conj (rule_elem ifheader) branches
	213	else branches
	214
	215	\| Ast.Disj(stmt_dots_list) ->
	216	let processed =
	217	List.map (statement_list testfn mcode tail) stmt_dots_list in
	218	(* if one branch gives no information, then we have to take anything *)
	219	if List.exists (function [] -> true \| _ -> false) processed
	220	then []
	221	else Common.union_all processed
	222
	223	\| Ast.Nest(stmt_dots,whencode,true,_,_) ->
	224	statement_list testfn mcode false stmt_dots
	225
	226	\| Ast.Nest(stmt_dots,whencode,false,_,_) -> []
	227
	228	\| Ast.Dots(_,whencodes,_,_) -> []
	229
708f4980 C	230	\| Ast.FunDecl(header,lbrace,body,rbrace) ->
708f4980 C	231	let body_info = statement_list testfn mcode true body in
34e49164 C	232	if testfn header or testfn lbrace or testfn rbrace
	233	then conj (rule_elem header) body_info
	234	else body_info
	235
	236	\| Ast.Define(header,body) ->
	237	conj_one testfn header (statement_list testfn mcode tail body)
	238
	239	\| Ast.OptStm(stm) -> []
	240
	241	\| Ast.UniqueStm(stm) -> statement testfn mcode tail stm
	242
	243	\| _ -> failwith "not supported"
	244
	245	and case_lines testfn mcode tail cases =
	246	match cases with
	247	[] -> []
	248	\| last::rest ->
	249	List.fold_right
	250	(function cur ->
	251	function rest ->
	252	conj (case_line testfn mcode false cur) rest)
	253	rest (case_line testfn mcode tail last)
	254
	255	and case_line testfn mcode tail case =
	256	match Ast.unwrap case with
	257	Ast.CaseLine(header,code) ->
	258	conj_one testfn header (statement_list testfn mcode tail code)
	259
	260	\| Ast.OptCase(case) -> []
	261
	262	(* --------------------------------------------------------------------- *)
	263	(* Function declaration *)
	264
	265	let top_level testfn mcode t : 'a list list =
	266	match Ast.unwrap t with
	267	Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo"
	268	\| Ast.DECL(stmt) -> statement testfn mcode false stmt
	269	\| Ast.CODE(stmt_dots) -> statement_list testfn mcode false stmt_dots
	270	\| Ast.ERRORWORDS(exps) -> failwith "not supported errorwords"
	271
	272	(* --------------------------------------------------------------------- *)
	273	(* Entry points *)
	274
	275	let debug = false
	276
	277	(* if we end up with nothing, we assume that this rule is only here because
	278	someone depends on it, and thus we try again with testfn as contains_modif.
	279	Alternatively, we could check that this rule is mentioned in some
	280	dependency, but that would be a little more work, and doesn't seem
	281	worthwhile. *)
	282
	283	(* lists are sorted such that smaller DisjRuleElem are first, because they
	284	are cheaper to test *)
	285
	286	let asttomemberz (_,_,l) used_after =
	287	let process_one (l : (int * Ast_cocci.rule_elem) list list) =
	288	if debug
	289	then print_info l;
	290	List.map
	291	(function info ->
	292	let info =
	293	List.sort (function (n1,_) -> function (n2,_) -> compare n1 n2)
	294	info in
	295	List.map (function (_,x) -> (Lib_engine.Match(x),CTL.Control)) info)
296	l in
297	List.map2
298	(function min -> function (max,big_max) ->
299	match min with
300	[] ->
301	(match max() with
302	[] -> process_one (big_max())
303	\| max -> process_one max)
304	\| _ -> process_one min)
305	(List.map (top_level contains_constant no_mcode) l)
306	(List.combine
307	(List.map2
308	(function x -> function ua -> function _ ->
309	top_level (contains_modif ua) mcode x)
310	l used_after)
311	(List.map
312	(function x -> function _ ->
313	top_level (function _ -> true) no_mcode x)
314	l))
315
316	let asttomember r used_after =
317	match r with
b1b2de81	318	Ast.ScriptRule _ \| Ast.InitialScriptRule _ \| Ast.FinalScriptRule _ -> []
faf9a90c	319	\| Ast.CocciRule (a,b,c,_,_) -> asttomemberz (a,b,c) used_after
34e49164	320