Release coccinelle-0.2.0rc1
[bpt/coccinelle.git] / parsing_cocci / unitary_ast0.ml
CommitLineData
34e49164
C
1(* find unitary metavariables *)
2module Ast0 = Ast0_cocci
3module Ast = Ast_cocci
4module V0 = Visitor_ast0
b1b2de81 5module VT0 = Visitor_ast0_types
34e49164
C
6
7let set_minus s minus = List.filter (function n -> not (List.mem n minus)) s
8
9let rec nub = function
10 [] -> []
11 | (x::xs) when (List.mem x xs) -> nub xs
12 | (x::xs) -> x::(nub xs)
13
14(* ----------------------------------------------------------------------- *)
15(* Find the variables that occur free and occur free in a unitary way *)
16
17(* take everything *)
18let minus_checker name = let id = Ast0.unwrap_mcode name in [id]
19
20(* take only what is in the plus code *)
708f4980 21let plus_checker (nm,_,_,mc,_,_) =
951c7801 22 match mc with Ast0.PLUS _ -> [nm] | _ -> []
faf9a90c 23
34e49164
C
24let get_free checker t =
25 let bind x y = x @ y in
26 let option_default = [] in
faf9a90c 27
34e49164
C
28 (* considers a single list *)
29 let collect_unitary_nonunitary free_usage =
30 let free_usage = List.sort compare free_usage in
31 let rec loop1 todrop = function
32 [] -> []
33 | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
34 let rec loop2 = function
35 [] -> ([],[])
36 | [x] -> ([x],[])
37 | x::y::xs ->
38 if x = y
39 then
40 let (unitary,non_unitary) = loop2(loop1 x xs) in
41 (unitary,x::non_unitary)
42 else
43 let (unitary,non_unitary) = loop2 (y::xs) in
44 (x::unitary,non_unitary) in
45 loop2 free_usage in
faf9a90c 46
34e49164
C
47 (* considers a list of lists *)
48 let detect_unitary_frees l =
49 let (unitary,nonunitary) =
50 List.split (List.map collect_unitary_nonunitary l) in
51 let unitary = nub (List.concat unitary) in
52 let nonunitary = nub (List.concat nonunitary) in
53 let unitary =
54 List.filter (function x -> not (List.mem x nonunitary)) unitary in
55 unitary@nonunitary@nonunitary in
56
1be43e12 57 let whencode afn bfn expression = function
34e49164
C
58 Ast0.WhenNot(a) -> afn a
59 | Ast0.WhenAlways(b) -> bfn b
1be43e12
C
60 | Ast0.WhenModifier(_) -> option_default
61 | Ast0.WhenNotTrue(a) -> expression a
62 | Ast0.WhenNotFalse(a) -> expression a in
faf9a90c 63
34e49164
C
64 let ident r k i =
65 match Ast0.unwrap i with
66 Ast0.MetaId(name,_,_) | Ast0.MetaFunc(name,_,_)
67 | Ast0.MetaLocalFunc(name,_,_) -> checker name
68 | _ -> k i in
faf9a90c 69
34e49164
C
70 let expression r k e =
71 match Ast0.unwrap e with
72 Ast0.MetaErr(name,_,_) | Ast0.MetaExpr(name,_,_,_,_)
73 | Ast0.MetaExprList(name,_,_) -> checker name
74 | Ast0.DisjExpr(starter,expr_list,mids,ender) ->
b1b2de81 75 detect_unitary_frees(List.map r.VT0.combiner_rec_expression expr_list)
34e49164 76 | _ -> k e in
faf9a90c 77
34e49164
C
78 let typeC r k t =
79 match Ast0.unwrap t with
80 Ast0.MetaType(name,_) -> checker name
81 | Ast0.DisjType(starter,types,mids,ender) ->
b1b2de81 82 detect_unitary_frees(List.map r.VT0.combiner_rec_typeC types)
34e49164 83 | _ -> k t in
faf9a90c 84
34e49164
C
85 let parameter r k p =
86 match Ast0.unwrap p with
87 Ast0.MetaParam(name,_) | Ast0.MetaParamList(name,_,_) -> checker name
88 | _ -> k p in
faf9a90c 89
34e49164
C
90 let declaration r k d =
91 match Ast0.unwrap d with
92 Ast0.DisjDecl(starter,decls,mids,ender) ->
b1b2de81 93 detect_unitary_frees(List.map r.VT0.combiner_rec_declaration decls)
34e49164
C
94 | _ -> k d in
95
fc1ad971
C
96 let case_line r k c =
97 match Ast0.unwrap c with
98 Ast0.DisjCase(starter,case_lines,mids,ender) ->
99 detect_unitary_frees(List.map r.VT0.combiner_rec_case_line case_lines)
100 | _ -> k c in
101
34e49164
C
102 let statement r k s =
103 match Ast0.unwrap s with
104 Ast0.MetaStmt(name,_) | Ast0.MetaStmtList(name,_) -> checker name
105 | Ast0.Disj(starter,stmt_list,mids,ender) ->
b1b2de81
C
106 detect_unitary_frees
107 (List.map r.VT0.combiner_rec_statement_dots stmt_list)
34e49164 108 | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
b1b2de81 109 bind (r.VT0.combiner_rec_statement_dots stmt_dots)
faf9a90c 110 (detect_unitary_frees
34e49164 111 (List.map
b1b2de81
C
112 (whencode
113 r.VT0.combiner_rec_statement_dots
114 r.VT0.combiner_rec_statement
115 r.VT0.combiner_rec_expression)
34e49164
C
116 whn))
117 | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
118 detect_unitary_frees
119 (List.map
b1b2de81
C
120 (whencode
121 r.VT0.combiner_rec_statement_dots r.VT0.combiner_rec_statement
122 r.VT0.combiner_rec_expression)
34e49164
C
123 whn)
124 | _ -> k s in
faf9a90c
C
125
126 let res = V0.combiner bind option_default
b1b2de81
C
127 {V0.combiner_functions with
128 VT0.combiner_identfn = ident;
129 VT0.combiner_exprfn = expression;
130 VT0.combiner_tyfn = typeC;
131 VT0.combiner_paramfn = parameter;
132 VT0.combiner_declfn = declaration;
fc1ad971
C
133 VT0.combiner_stmtfn = statement;
134 VT0.combiner_casefn = case_line} in
faf9a90c 135
34e49164 136 collect_unitary_nonunitary
b1b2de81 137 (List.concat (List.map res.VT0.combiner_rec_top_level t))
faf9a90c 138
34e49164
C
139(* ----------------------------------------------------------------------- *)
140(* update the variables that are unitary *)
faf9a90c 141
34e49164 142let update_unitary unitary =
34e49164
C
143 let is_unitary name =
144 match (List.mem (Ast0.unwrap_mcode name) unitary,
485bce71
C
145 !Flag.sgrep_mode2, Ast0.get_mcode_mcodekind name) with
146 (true,true,_) | (true,_,Ast0.CONTEXT(_)) -> Ast0.PureContext
147 | (true,_,_) -> Ast0.Pure
148 | (false,true,_) | (false,_,Ast0.CONTEXT(_)) -> Ast0.Context
149 | (false,_,_) -> Ast0.Impure in
34e49164
C
150
151 let ident r k i =
152 match Ast0.unwrap i with
153 Ast0.MetaId(name,constraints,_) ->
154 Ast0.rewrap i (Ast0.MetaId(name,constraints,is_unitary name))
155 | Ast0.MetaFunc(name,constraints,_) ->
156 Ast0.rewrap i (Ast0.MetaFunc(name,constraints,is_unitary name))
157 | Ast0.MetaLocalFunc(name,constraints,_) ->
158 Ast0.rewrap i (Ast0.MetaLocalFunc(name,constraints,is_unitary name))
159 | _ -> k i in
160
161 let expression r k e =
162 match Ast0.unwrap e with
163 Ast0.MetaErr(name,constraints,_) ->
164 Ast0.rewrap e (Ast0.MetaErr(name,constraints,is_unitary name))
165 | Ast0.MetaExpr(name,constraints,ty,form,_) ->
166 Ast0.rewrap e (Ast0.MetaExpr(name,constraints,ty,form,is_unitary name))
167 | Ast0.MetaExprList(name,lenname,_) ->
168 Ast0.rewrap e (Ast0.MetaExprList(name,lenname,is_unitary name))
169 | _ -> k e in
faf9a90c 170
34e49164
C
171 let typeC r k t =
172 match Ast0.unwrap t with
173 Ast0.MetaType(name,_) ->
174 Ast0.rewrap t (Ast0.MetaType(name,is_unitary name))
175 | _ -> k t in
faf9a90c 176
34e49164
C
177 let parameter r k p =
178 match Ast0.unwrap p with
179 Ast0.MetaParam(name,_) ->
180 Ast0.rewrap p (Ast0.MetaParam(name,is_unitary name))
181 | Ast0.MetaParamList(name,lenname,_) ->
182 Ast0.rewrap p (Ast0.MetaParamList(name,lenname,is_unitary name))
183 | _ -> k p in
faf9a90c 184
34e49164
C
185 let statement r k s =
186 match Ast0.unwrap s with
187 Ast0.MetaStmt(name,_) ->
188 Ast0.rewrap s (Ast0.MetaStmt(name,is_unitary name))
189 | Ast0.MetaStmtList(name,_) ->
190 Ast0.rewrap s (Ast0.MetaStmtList(name,is_unitary name))
191 | _ -> k s in
faf9a90c 192
34e49164 193 let res = V0.rebuilder
b1b2de81
C
194 {V0.rebuilder_functions with
195 VT0.rebuilder_identfn = ident;
196 VT0.rebuilder_exprfn = expression;
197 VT0.rebuilder_tyfn = typeC;
198 VT0.rebuilder_paramfn = parameter;
199 VT0.rebuilder_stmtfn = statement} in
34e49164 200
b1b2de81 201 List.map res.VT0.rebuilder_rec_top_level
34e49164
C
202
203(* ----------------------------------------------------------------------- *)
204
205let rec split3 = function
206 [] -> ([],[],[])
207 | (a,b,c)::xs -> let (l1,l2,l3) = split3 xs in (a::l1,b::l2,c::l3)
208
209let rec combine3 = function
210 ([],[],[]) -> []
211 | (a::l1,b::l2,c::l3) -> (a,b,c) :: combine3 (l1,l2,l3)
212 | _ -> failwith "not possible"
213
214(* ----------------------------------------------------------------------- *)
215(* process all rules *)
216
217let do_unitary rules =
218 let rec loop = function
219 [] -> ([],[])
220 | (r::rules) ->
221 match r with
b1b2de81
C
222 Ast0.ScriptRule (_,_,_,_)
223 | Ast0.InitialScriptRule (_,_) | Ast0.FinalScriptRule (_,_) ->
34e49164
C
224 let (x,rules) = loop rules in
225 (x, r::rules)
faf9a90c 226 | Ast0.CocciRule ((minus,metavars,chosen_isos),((plus,_) as plusz),rt) ->
34e49164
C
227 let mm1 = List.map Ast.get_meta_name metavars in
228 let (used_after, rest) = loop rules in
229 let (m_unitary, m_nonunitary) = get_free minus_checker minus in
230 let (p_unitary, p_nonunitary) = get_free plus_checker plus in
faf9a90c 231 let p_free =
34e49164
C
232 if !Flag.sgrep_mode2 then []
233 else p_unitary @ p_nonunitary in
234 let (in_p, m_unitary) =
235 List.partition (function x -> List.mem x p_free) m_unitary in
236 let m_nonunitary = in_p @ m_nonunitary in
237 let (m_unitary, not_local) =
238 List.partition (function x -> List.mem x mm1) m_unitary in
239 let m_unitary =
240 List.filter (function x -> not (List.mem x used_after))
241 m_unitary in
242 let rebuilt = update_unitary m_unitary minus in
243 (set_minus (m_nonunitary @ used_after) mm1,
244 (Ast0.CocciRule
faf9a90c 245 ((rebuilt, metavars, chosen_isos),plusz,rt))::rest) in
34e49164
C
246 let (_,rules) = loop rules in
247 rules
248
249(*
250let do_unitary minus plus =
251 let (minus,metavars,chosen_isos) = split3 minus in
252 let (plus,_) = List.split plus in
253 let rec loop = function
254 ([],[],[]) -> ([],[])
255 | (mm1::metavars,m1::minus,p1::plus) ->
256 let mm1 = List.map Ast.get_meta_name mm1 in
257 let (used_after,rest) = loop (metavars,minus,plus) in
258 let (m_unitary,m_nonunitary) = get_free minus_checker m1 in
259 let (p_unitary,p_nonunitary) = get_free plus_checker p1 in
260 let p_free =
261 if !Flag.sgrep_mode2
262 then []
263 else p_unitary @ p_nonunitary in
264 let (in_p,m_unitary) =
265 List.partition (function x -> List.mem x p_free) m_unitary in
266 let m_nonunitary = in_p@m_nonunitary in
267 let (m_unitary,not_local) =
268 List.partition (function x -> List.mem x mm1) m_unitary in
269 let m_unitary =
270 List.filter (function x -> not(List.mem x used_after)) m_unitary in
271 let rebuilt = update_unitary m_unitary m1 in
272 (set_minus (m_nonunitary @ used_after) mm1,
273 rebuilt::rest)
274 | _ -> failwith "not possible" in
275 let (_,rules) = loop (metavars,minus,plus) in
276 combine3 (rules,metavars,chosen_isos)
277*)