lustrec / src / mutation.ml @ bde99c3f
History  View  Annotate  Download (20.6 KB)
1 
open LustreSpec 

2 
open Corelang 
3 
open Log 
4 
open Format 
5  
6 
let random_seed = ref 0 
7 
let threshold_delay = 95 
8 
let threshold_inc_int = 97 
9 
let threshold_dec_int = 97 
10 
let threshold_random_int = 96 
11 
let threshold_switch_int = 100 (* not implemented yet *) 
12 
let threshold_random_float = 100 (* not used yet *) 
13 
let threshold_negate_bool_var = 95 
14 
let threshold_arith_op = 95 
15 
let threshold_rel_op = 95 
16 
let threshold_bool_op = 95 
17  
18 
let int_consts = ref [] 
19  
20 
let rename_app id = 
21 
if !Options.no_mutation_suffix then 
22 
id 
23 
else 
24 
id ^ "_mutant" 
25  
26 
(************************************************************************************) 
27 
(* Gathering constants in the code *) 
28 
(************************************************************************************) 
29  
30 
module IntSet = Set.Make (struct type t = int let compare = compare end) 
31 
module OpCount = Mmap.Make (struct type t = string let compare = compare end) 
32  
33 
type records = { 
34 
consts: IntSet.t; 
35 
nb_boolexpr: int; 
36 
nb_pre: int; 
37 
nb_op: int OpCount.t; 
38 
} 
39  
40 
let arith_op = ["+" ; "" ; "*" ; "/"] 
41 
let bool_op = ["&&"; ""; "xor"; "impl"] 
42 
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
43 
let ops = arith_op @ bool_op @ rel_op 
44 
let all_ops = "not" :: ops 
45  
46 
let empty_records = 
47 
{consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty} 
48  
49 
let records = ref empty_records 
50  
51 
let merge_records records_list = 
52 
let merge_record r1 r2 = 
53 
{ 
54 
consts = IntSet.union r1.consts r2.consts; 
55  
56 
nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr; 
57 
nb_pre = r1.nb_pre + r2.nb_pre; 
58  
59 
nb_op = OpCount.merge (fun op r1opt r2opt > 
60 
match r1opt, r2opt with 
61 
 None, _ > r2opt 
62 
 _, None > r1opt 
63 
 Some x, Some y > Some (x+y) 
64 
) r1.nb_op r2.nb_op 
65 
} 
66 
in 
67 
List.fold_left merge_record empty_records records_list 
68 

69 
let compute_records_const_value c = 
70 
match c with 
71 
 Const_int i > {empty_records with consts = IntSet.singleton i} 
72 
 _ > empty_records 
73  
74 
let rec compute_records_expr expr = 
75 
let boolexpr = 
76 
if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then 
77 
{empty_records with nb_boolexpr = 1} 
78 
else 
79 
empty_records 
80 
in 
81 
let subrec = 
82 
match expr.expr_desc with 
83 
 Expr_const c > compute_records_const_value c 
84 
 Expr_tuple l > merge_records (List.map compute_records_expr l) 
85 
 Expr_ite (i,t,e) > 
86 
merge_records (List.map compute_records_expr [i;t;e]) 
87 
 Expr_arrow (e1, e2) > 
88 
merge_records (List.map compute_records_expr [e1;e2]) 
89 
 Expr_pre e > 
90 
merge_records ( 
91 
({empty_records with nb_pre = 1}) 
92 
::[compute_records_expr e]) 
93 
 Expr_appl (op_id, args, r) > 
94 
if List.mem op_id ops then 
95 
merge_records ( 
96 
({empty_records with nb_op = OpCount.singleton op_id 1}) 
97 
::[compute_records_expr args]) 
98 
else 
99 
compute_records_expr args 
100 
 _ > empty_records 
101 
in 
102 
merge_records [boolexpr;subrec] 
103  
104 
let compute_records_eq eq = compute_records_expr eq.eq_rhs 
105  
106 
let compute_records_node nd = 
107 
merge_records (List.map compute_records_eq (get_node_eqs nd)) 
108  
109 
let compute_records_top_decl td = 
110 
match td.top_decl_desc with 
111 
 Node nd > compute_records_node nd 
112 
 Const cst > compute_records_const_value cst.const_value 
113 
 _ > empty_records 
114  
115 
let compute_records prog = 
116 
merge_records (List.map compute_records_top_decl prog) 
117  
118 
(*****************************************************************) 
119 
(* Random mutation *) 
120 
(*****************************************************************) 
121  
122 
let check_mut e1 e2 = 
123 
let rec eq e1 e2 = 
124 
match e1.expr_desc, e2.expr_desc with 
125 
 Expr_const c1, Expr_const c2 > c1 = c2 
126 
 Expr_ident id1, Expr_ident id2 > id1 = id2 
127 
 Expr_tuple el1, Expr_tuple el2 > List.length el1 = List.length el2 && List.for_all2 eq el1 el2 
128 
 Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) > eq i1 i2 && eq t1 t2 && eq e1 e2 
129 
 Expr_arrow (x1, y1), Expr_arrow (x2, y2) > eq x1 x2 && eq y1 y2 
130 
 Expr_pre e1, Expr_pre e2 > eq e1 e2 
131 
 Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) > id1 = id2 && eq e1 e2 
132 
 _ > false 
133 
in 
134 
if not (eq e1 e2) then 
135 
Some (e1, e2) 
136 
else 
137 
None 
138  
139 
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c) 
140  
141 
let rdm_mutate_int i = 
142 
if Random.int 100 > threshold_inc_int then 
143 
i+1 
144 
else if Random.int 100 > threshold_dec_int then 
145 
i1 
146 
else if Random.int 100 > threshold_random_int then 
147 
Random.int 10 
148 
else if Random.int 100 > threshold_switch_int then 
149 
let idx = Random.int (List.length !int_consts) in 
150 
List.nth !int_consts idx 
151 
else 
152 
i 
153 

154 
let rdm_mutate_real r = 
155 
if Random.int 100 > threshold_random_float then 
156 
(* interval [0, bound] for random values *) 
157 
let bound = 10 in 
158 
(* max number of digits after comma *) 
159 
let digits = 5 in 
160 
(* number of digits after comma *) 
161 
let shift = Random.int (digits + 1) in 
162 
let eshift = 10. ** (float_of_int shift) in 
163 
let i = Random.int (1 + bound * (int_of_float eshift)) in 
164 
let f = float_of_int i /. eshift in 
165 
(Num.num_of_int i, shift, string_of_float f) 
166 
else 
167 
r 
168  
169 
let rdm_mutate_op op = 
170 
match op with 
171 
 "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > 
172 
let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in 
173 
List.nth filtered (Random.int 3) 
174 
 "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op > 
175 
let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in 
176 
List.nth filtered (Random.int 3) 
177 
 "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op > 
178 
let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in 
179 
List.nth filtered (Random.int 5) 
180 
 _ > op 
181  
182  
183 
let rdm_mutate_var expr = 
184 
match (Types.repr expr.expr_type).Types.tdesc with 
185 
 Types.Tbool > 
186 
(* if Random.int 100 > threshold_negate_bool_var then *) 
187 
let new_e = mkpredef_call expr.expr_loc "not" [expr] in 
188 
Some (expr, new_e), new_e 
189 
(* else *) 
190 
(* expr *) 
191 
 _ > None, expr 
192 

193 
let rdm_mutate_pre orig_expr = 
194 
let new_e = Expr_pre orig_expr in 
195 
Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e 
196  
197  
198 
let rdm_mutate_const_value c = 
199 
match c with 
200 
 Const_int i > Const_int (rdm_mutate_int i) 
201 
 Const_real (n, i, s) > let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s') 
202 
 Const_array _ 
203 
 Const_string _ 
204 
 Const_struct _ 
205 
 Const_tag _ > c 
206  
207 
let rdm_mutate_const c = 
208 
let new_const = rdm_mutate_const_value c.const_value in 
209 
let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in 
210 
mut, { c with const_value = new_const } 
211  
212  
213 
let select_in_list list rdm_mutate_elem = 
214 
let selected = Random.int (List.length list) in 
215 
let mutation_opt, new_list, _ = 
216 
List.fold_right 
217 
(fun elem (mutation_opt, res, cpt) > if cpt = selected then 
218 
let mutation, new_elem = rdm_mutate_elem elem in 
219 
Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1) 
220 
list 
221 
(None, [], 0) 
222 
in 
223 
match mutation_opt with 
224 
 Some mut > mut, new_list 
225 
 _ > assert false 
226  
227  
228 
let rec rdm_mutate_expr expr = 
229 
let mk_e d = { expr with expr_desc = d } in 
230 
match expr.expr_desc with 
231 
 Expr_ident id > rdm_mutate_var expr 
232 
 Expr_const c > 
233 
let new_const = rdm_mutate_const_value c in 
234 
let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in 
235 
mut, mk_e (Expr_const new_const) 
236 
 Expr_tuple l > 
237 
let mut, l' = select_in_list l rdm_mutate_expr in 
238 
mut, mk_e (Expr_tuple l') 
239 
 Expr_ite (i,t,e) > 
240 
let mut, [i'; t'; e'] = select_in_list [i; t; e] rdm_mutate_expr in 
241 
mut, mk_e (Expr_ite (i', t', e')) 
242 
 Expr_arrow (e1, e2) > 
243 
let mut, [e1'; e2'] = select_in_list [e1; e2] rdm_mutate_expr in 
244 
mut, mk_e (Expr_arrow (e1', e2')) 
245 
 Expr_pre e > 
246 
let select_pre = Random.bool () in 
247 
if select_pre then 
248 
let mut, new_expr = rdm_mutate_pre expr in 
249 
mut, mk_e new_expr 
250 
else 
251 
let mut, e' = rdm_mutate_expr e in 
252 
mut, mk_e (Expr_pre e') 
253 
 Expr_appl (op_id, args, r) > 
254 
let select_op = Random.bool () in 
255 
if select_op then 
256 
let new_op_id = rdm_mutate_op op_id in 
257 
let new_e = mk_e (Expr_appl (new_op_id, args, r)) in 
258 
let mut = check_mut expr new_e in 
259 
mut, new_e 
260 
else 
261 
let mut, new_args = rdm_mutate_expr args in 
262 
mut, mk_e (Expr_appl (op_id, new_args, r)) 
263 
(* Other constructs are kept. 
264 
 Expr_fby of expr * expr 
265 
 Expr_array of expr list 
266 
 Expr_access of expr * Dimension.dim_expr 
267 
 Expr_power of expr * Dimension.dim_expr 
268 
 Expr_when of expr * ident * label 
269 
 Expr_merge of ident * (label * expr) list 
270 
 Expr_uclock of expr * int 
271 
 Expr_dclock of expr * int 
272 
 Expr_phclock of expr * rat *) 
273 
 _ > None, expr 
274 

275  
276 
let rdm_mutate_eq eq = 
277 
let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in 
278 
mutation, { eq with eq_rhs = new_rhs } 
279  
280 
let rnd_mutate_stmt stmt = 
281 
match stmt with 
282 
 Eq eq > let mut, new_eq = rdm_mutate_eq eq in 
283 
report ~level:1 
284 
(fun fmt > fprintf fmt "mutation: %a becomes %a@." 
285 
Printers.pp_node_eq eq 
286 
Printers.pp_node_eq new_eq); 
287 
mut, Eq new_eq 
288 
 Aut aut > assert false 
289  
290 
let rdm_mutate_node nd = 
291 
let mutation, new_node_stmts = 
292 
select_in_list 
293 
nd.node_stmts rnd_mutate_stmt 
294 
in 
295 
mutation, { nd with node_stmts = new_node_stmts } 
296  
297 
let rdm_mutate_top_decl td = 
298 
match td.top_decl_desc with 
299 
 Node nd > 
300 
let mutation, new_node = rdm_mutate_node nd in 
301 
mutation, { td with top_decl_desc = Node new_node} 
302 
 Const cst > 
303 
let mut, new_cst = rdm_mutate_const cst in 
304 
mut, { td with top_decl_desc = Const new_cst } 
305 
 _ > None, td 
306 

307 
(* Create a single mutant with the provided random seed *) 
308 
let rdm_mutate_prog prog = 
309 
select_in_list prog rdm_mutate_top_decl 
310  
311 
let rdm_mutate nb prog = 
312 
let rec iterate nb res = 
313 
incr random_seed; 
314 
if nb <= 0 then 
315 
res 
316 
else ( 
317 
Random.init !random_seed; 
318 
let mutation, new_mutant = rdm_mutate_prog prog in 
319 
match mutation with 
320 
None > iterate nb res 
321 
 Some mutation > ( 
322 
if List.mem_assoc mutation res then ( 
323 
iterate nb res 
324 
) 
325 
else ( 
326 
report ~level:1 (fun fmt > fprintf fmt "%i mutants remaining@." nb); 
327 
iterate (nb1) ((mutation, new_mutant)::res) 
328 
) 
329 
) 
330 
) 
331 
in 
332 
iterate nb [] 
333  
334  
335 
(*****************************************************************) 
336 
(* Random mutation *) 
337 
(*****************************************************************) 
338  
339 
type mutant_t = Boolexpr of int  Pre of int  Op of string * int * string  IncrIntCst of int  DecrIntCst of int  SwitchIntCst of int * int 
340  
341 
let target : mutant_t option ref = ref None 
342  
343 
let print_directive fmt d = 
344 
match d with 
345 
 Pre n > Format.fprintf fmt "pre %i" n 
346 
 Boolexpr n > Format.fprintf fmt "boolexpr %i" n 
347 
 Op (o, i, d) > Format.fprintf fmt "%s %i > %s" o i d 
348 
 IncrIntCst n > Format.fprintf fmt "incr int cst %i" n 
349 
 DecrIntCst n > Format.fprintf fmt "decr int cst %i" n 
350 
 SwitchIntCst (n, m) > Format.fprintf fmt "switch int cst %i > %i" n m 
351  
352 
let fold_mutate_int i = 
353 
if Random.int 100 > threshold_inc_int then 
354 
i+1 
355 
else if Random.int 100 > threshold_dec_int then 
356 
i1 
357 
else if Random.int 100 > threshold_random_int then 
358 
Random.int 10 
359 
else if Random.int 100 > threshold_switch_int then 
360 
try 
361 
let idx = Random.int (List.length !int_consts) in 
362 
List.nth !int_consts idx 
363 
with _ > i 
364 
else 
365 
i 
366 

367 
let fold_mutate_float f = 
368 
if Random.int 100 > threshold_random_float then 
369 
Random.float 10. 
370 
else 
371 
f 
372  
373 
let fold_mutate_op op = 
374 
(* match op with *) 
375 
(*  "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > *) 
376 
(* let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in *) 
377 
(* List.nth filtered (Random.int 3) *) 
378 
(*  "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op > *) 
379 
(* let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in *) 
380 
(* List.nth filtered (Random.int 3) *) 
381 
(*  "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op > *) 
382 
(* let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *) 
383 
(* List.nth filtered (Random.int 5) *) 
384 
(*  _ > op *) 
385 
match !target with 
386 
 Some (Op(op_orig, 0, op_new)) when op_orig = op > ( 
387 
target := None; 
388 
op_new 
389 
) 
390 
 Some (Op(op_orig, n, op_new)) when op_orig = op > ( 
391 
target := Some (Op(op_orig, n1, op_new)); 
392 
op 
393 
) 
394 
 _ > if List.mem op Basic_library.internal_funs then op else rename_app op 
395  
396  
397 
let fold_mutate_var expr = 
398 
(* match (Types.repr expr.expr_type).Types.tdesc with *) 
399 
(*  Types.Tbool > *) 
400 
(* (\* if Random.int 100 > threshold_negate_bool_var then *\) *) 
401 
(* mkpredef_unary_call Location.dummy_loc "not" expr *) 
402 
(* (\* else *\) *) 
403 
(* (\* expr *\) *) 
404 
(*  _ > 
405 
*)expr 
406  
407 
let fold_mutate_boolexpr expr = 
408 
match !target with 
409 
 Some (Boolexpr 0) > ( 
410 
target := None; 
411 
mkpredef_call expr.expr_loc "not" [expr] 
412 
) 
413 
 Some (Boolexpr n) > 
414 
(target := Some (Boolexpr (n1)); expr) 
415 
 _ > expr 
416 

417 
let fold_mutate_pre orig_expr e = 
418 
match !target with 
419 
Some (Pre 0) > ( 
420 
target := None; 
421 
Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
422 
) 
423 
 Some (Pre n) > ( 
424 
target := Some (Pre (n1)); 
425 
Expr_pre e 
426 
) 
427 
 _ > Expr_pre e 
428 

429 
let fold_mutate_const_value c = 
430 
match c with 
431 
 Const_int i > ( 
432 
match !target with 
433 
 Some (IncrIntCst 0) > (target := None; Const_int (i+1)) 
434 
 Some (DecrIntCst 0) > (target := None; Const_int (i1)) 
435 
 Some (SwitchIntCst (0, id)) > (target := None; Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id)) 
436 
 Some (IncrIntCst n) > (target := Some (IncrIntCst (n1)); c) 
437 
 Some (DecrIntCst n) > (target := Some (DecrIntCst (n1)); c) 
438 
 Some (SwitchIntCst (n, id)) > (target := Some (SwitchIntCst (n1, id)); c) 
439 
 _ > c) 
440 
 _ > c 
441  
442 
(* 
443 
match c with 
444 
 Const_int i > Const_int (fold_mutate_int i) 
445 
 Const_real s > Const_real s (* those are string, let's leave them *) 
446 
 Const_float f > Const_float (fold_mutate_float f) 
447 
 Const_array _ 
448 
 Const_tag _ > c 
449 
TODO 
450  
451 
*) 
452 
let fold_mutate_const c = 
453 
{ c with const_value = fold_mutate_const_value c.const_value } 
454  
455 
let rec fold_mutate_expr expr = 
456 
let new_expr = 
457 
match expr.expr_desc with 
458 
 Expr_ident id > fold_mutate_var expr 
459 
 _ > ( 
460 
let new_desc = match expr.expr_desc with 
461 
 Expr_const c > Expr_const (fold_mutate_const_value c) 
462 
 Expr_tuple l > Expr_tuple (List.fold_right (fun e res > (fold_mutate_expr e)::res) l []) 
463 
 Expr_ite (i,t,e) > Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e) 
464 
 Expr_arrow (e1, e2) > Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2) 
465 
 Expr_pre e > fold_mutate_pre expr (fold_mutate_expr e) 
466 
 Expr_appl (op_id, args, r) > Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r) 
467 
(* Other constructs are kept. 
468 
 Expr_fby of expr * expr 
469 
 Expr_array of expr list 
470 
 Expr_access of expr * Dimension.dim_expr 
471 
 Expr_power of expr * Dimension.dim_expr 
472 
 Expr_when of expr * ident * label 
473 
 Expr_merge of ident * (label * expr) list 
474 
 Expr_uclock of expr * int 
475 
 Expr_dclock of expr * int 
476 
 Expr_phclock of expr * rat *) 
477 
 _ > expr.expr_desc 
478 

479 
in 
480 
{ expr with expr_desc = new_desc } 
481 
) 
482 
in 
483 
if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then 
484 
fold_mutate_boolexpr new_expr 
485 
else 
486 
new_expr 
487  
488 
let fold_mutate_eq eq = 
489 
{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs } 
490  
491 
let fold_mutate_stmt stmt = 
492 
match stmt with 
493 
 Eq eq > Eq (fold_mutate_eq eq) 
494 
 Aut aut > assert false 
495  
496 
let fold_mutate_node nd = 
497 
{ nd with 
498 
node_stmts = 
499 
List.fold_right (fun stmt res > (fold_mutate_stmt stmt)::res) nd.node_stmts []; 
500 
node_id = rename_app nd.node_id 
501 
} 
502  
503 
let fold_mutate_top_decl td = 
504 
match td.top_decl_desc with 
505 
 Node nd > { td with top_decl_desc = Node (fold_mutate_node nd)} 
506 
 Const cst > { td with top_decl_desc = Const (fold_mutate_const cst)} 
507 
 _ > td 
508 

509 
(* Create a single mutant with the provided random seed *) 
510 
let fold_mutate_prog prog = 
511 
List.fold_right (fun e res > (fold_mutate_top_decl e)::res) prog [] 
512  
513 
let create_mutant prog directive = 
514 
target := Some directive; 
515 
let prog' = fold_mutate_prog prog in 
516 
target := None; 
517 
prog' 
518 

519  
520 
let op_mutation op = 
521 
let res = 
522 
let rem_op l = List.filter (fun e > e <> op) l in 
523 
if List.mem op arith_op then rem_op arith_op else 
524 
if List.mem op bool_op then rem_op bool_op else 
525 
if List.mem op rel_op then rem_op rel_op else 
526 
(Format.eprintf "Failing with op %s@." op; 
527 
assert false 
528 
) 
529 
in 
530 
(* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *) 
531 
res 
532  
533 
let rec remains select list = 
534 
match list with 
535 
[] > [] 
536 
 hd::tl > if select hd then tl else remains select tl 
537 

538 
let next_change m = 
539 
let res = 
540 
let rec first_op () = 
541 
try 
542 
let min_binding = OpCount.min_binding !records.nb_op in 
543 
Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding))) 
544 
with Not_found > first_boolexpr () 
545 
and first_boolexpr () = 
546 
if !records.nb_boolexpr > 0 then 
547 
Boolexpr 0 
548 
else first_pre () 
549 
and first_pre () = 
550 
if !records.nb_pre > 0 then 
551 
Pre 0 
552 
else 
553 
first_op () 
554 
and first_intcst () = 
555 
if IntSet.cardinal !records.consts > 0 then 
556 
IncrIntCst 0 
557 
else 
558 
first_boolexpr () 
559 
in 
560 
match m with 
561 
 Boolexpr n > 
562 
if n+1 >= !records.nb_boolexpr then 
563 
first_pre () 
564 
else 
565 
Boolexpr (n+1) 
566 
 Pre n > 
567 
if n+1 >= !records.nb_pre then 
568 
first_op () 
569 
else Pre (n+1) 
570 
 Op (orig, id, mut_op) > ( 
571 
match remains (fun x > x = mut_op) (op_mutation orig) with 
572 
 next_op::_ > Op (orig, id, next_op) 
573 
 [] > if id+1 >= OpCount.find orig !records.nb_op then ( 
574 
match remains (fun (k1, _) > k1 = orig) (OpCount.bindings !records.nb_op) with 
575 
 [] > first_intcst () 
576 
 hd::_ > Op (fst hd, 0, List.hd (op_mutation (fst hd))) 
577 
) else 
578 
Op(orig, id+1, List.hd (op_mutation orig)) 
579 
) 
580 
 IncrIntCst n > 
581 
if n+1 >= IntSet.cardinal !records.consts then 
582 
DecrIntCst 0 
583 
else IncrIntCst (n+1) 
584 
 DecrIntCst n > 
585 
if n+1 >= IntSet.cardinal !records.consts then 
586 
SwitchIntCst (0, 0) 
587 
else DecrIntCst (n+1) 
588 
 SwitchIntCst (n, m) > 
589 
if m+1 > 1 + IntSet.cardinal !records.consts then 
590 
SwitchIntCst (n, m+1) 
591 
else if n+1 >= IntSet.cardinal !records.consts then 
592 
SwitchIntCst (n+1, 0) 
593 
else first_boolexpr () 
594  
595 
in 
596 
(* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *) 
597 
res 
598  
599 
let fold_mutate nb prog = 
600 
incr random_seed; 
601 
Random.init !random_seed; 
602 
let find_next_new mutants mutant = 
603 
let rec find_next_new init current = 
604 
if init = current then raise Not_found else 
605 
if List.mem current mutants then 
606 
find_next_new init (next_change current) 
607 
else 
608 
current 
609 
in 
610 
find_next_new mutant (next_change mutant) 
611 
in 
612 
(* Creating list of nb elements of mutants *) 
613 
let rec create_mutants_directives rnb mutants = 
614 
if rnb <= 0 then mutants 
615 
else 
616 
let random_mutation = 
617 
match Random.int 6 with 
618 
 5 > IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ > 0) 
619 
 4 > DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ > 0) 
620 
 3 > SwitchIntCst ((try Random.int (IntSet.cardinal !records.consts) with _ > 0), (try Random.int (1 + IntSet.cardinal !records.consts) with _ > 0)) 
621 
 2 > Pre (try Random.int !records.nb_pre with _ > 0) 
622 
 1 > Boolexpr (try Random.int !records.nb_boolexpr with _ > 0) 
623 
 0 > let bindings = OpCount.bindings !records.nb_op in 
624 
let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ > 0) in 
625 
let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ > 0) in 
626 
Op (op, (try Random.int nb_op with _ > 0), new_op) 
627 
 _ > assert false 
628 
in 
629 
if List.mem random_mutation mutants then 
630 
try 
631 
let new_mutant = (find_next_new mutants random_mutation) in 
632 
report ~level:2 (fun fmt > fprintf fmt " %i mutants generated out of %i expected@." (nbrnb) nb); 
633 
create_mutants_directives (rnb1) (new_mutant::mutants) 
634 
with Not_found > ( 
635 
report ~level:1 (fun fmt > fprintf fmt "Only %i mutants generated out of %i expected@." (nbrnb) nb); 
636 
mutants 
637 
) 
638 
else 
639 
create_mutants_directives (rnb1) (random_mutation::mutants) 
640 
in 
641 
let mutants_directives = create_mutants_directives nb [] in 
642 
List.map (fun d > d, create_mutant prog d) mutants_directives 
643 

644  
645 
let mutate nb prog = 
646 
records := compute_records prog; 
647 
(* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *) 
648 
(* !records.nb_pre *) 
649 
(* !records.nb_boolexpr *) 
650 
(* (\* !records.op *\) *) 
651 
(* ; *) 
652 
fold_mutate nb prog, print_directive 
653  
654  
655  
656  
657 
(* Local Variables: *) 
658 
(* compilecommand:"make C .." *) 
659 
(* End: *) 
660  
661 
