lustrec / src / mutation.ml @ e8f55c25
History  View  Annotate  Download (26.8 KB)
1  

2 
(* Comments in function fold_mutate 
3  
4 
TODO: check if we can generate more cases. The following lines were 
5 
cylcing and missing to detect that the enumaration was complete, 
6 
leading to a non terminating process. The current setting is harder 
7 
but may miss enumerating some cases. To be checked! 
8 

9  
10 
*) 
11  
12  
13 
open Lustre_types 
14 
open Corelang 
15 
open Log 
16 
open Format 
17  
18 
let random_seed = ref 0 
19 
let threshold_delay = 95 
20 
let threshold_inc_int = 97 
21 
let threshold_dec_int = 97 
22 
let threshold_random_int = 96 
23 
let threshold_switch_int = 100 (* not implemented yet *) 
24 
let threshold_random_float = 100 (* not used yet *) 
25 
let threshold_negate_bool_var = 95 
26 
let threshold_arith_op = 95 
27 
let threshold_rel_op = 95 
28 
let threshold_bool_op = 95 
29  
30 
let int_consts = ref [] 
31  
32 
let rename_app id = 
33 
if List.mem id Basic_library.internal_funs  
34 
!Options.no_mutation_suffix then 
35 
id 
36 
else 
37 
let node = Corelang.node_from_name id in 
38 
let is_imported = 
39 
match node.top_decl_desc with 
40 
 ImportedNode _ > true 
41 
 _ > false 
42 
in 
43 
if is_imported then 
44 
id 
45 
else 
46 
id ^ "_mutant" 
47  
48 
(************************************************************************************) 
49 
(* Gathering constants in the code *) 
50 
(************************************************************************************) 
51  
52 
module IntSet = Set.Make (struct type t = int let compare = compare end) 
53 
module OpCount = Mmap.Make (struct type t = string let compare = compare end) 
54  
55 
type records = { 
56 
consts: IntSet.t; 
57 
nb_consts: int; 
58 
nb_boolexpr: int; 
59 
nb_pre: int; 
60 
nb_op: int OpCount.t; 
61 
} 
62  
63 
let arith_op = ["+" ; "" ; "*" ; "/"] 
64 
let bool_op = ["&&"; ""; "xor"; "impl"] 
65 
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
66 
let ops = arith_op @ bool_op @ rel_op 
67 
let all_ops = "not" :: ops 
68  
69 
let empty_records = 
70 
{consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty} 
71  
72 
let records = ref empty_records 
73  
74 
let merge_records records_list = 
75 
let merge_record r1 r2 = 
76 
{ 
77 
consts = IntSet.union r1.consts r2.consts; 
78  
79 
nb_consts = r1.nb_consts + r2.nb_consts; 
80 
nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr; 
81 
nb_pre = r1.nb_pre + r2.nb_pre; 
82  
83 
nb_op = OpCount.merge (fun op r1opt r2opt > 
84 
match r1opt, r2opt with 
85 
 None, _ > r2opt 
86 
 _, None > r1opt 
87 
 Some x, Some y > Some (x+y) 
88 
) r1.nb_op r2.nb_op 
89 
} 
90 
in 
91 
List.fold_left merge_record empty_records records_list 
92 

93 
let compute_records_const_value c = 
94 
match c with 
95 
 Const_int i > {empty_records with consts = IntSet.singleton i; nb_consts = 1} 
96 
 _ > empty_records 
97  
98 
let rec compute_records_expr expr = 
99 
let boolexpr = 
100 
if Types.is_bool_type expr.expr_type then 
101 
{empty_records with nb_boolexpr = 1} 
102 
else 
103 
empty_records 
104 
in 
105 
let subrec = 
106 
match expr.expr_desc with 
107 
 Expr_const c > compute_records_const_value c 
108 
 Expr_tuple l > merge_records (List.map compute_records_expr l) 
109 
 Expr_ite (i,t,e) > 
110 
merge_records (List.map compute_records_expr [i;t;e]) 
111 
 Expr_arrow (e1, e2) > 
112 
merge_records (List.map compute_records_expr [e1;e2]) 
113 
 Expr_pre e > 
114 
merge_records ( 
115 
({empty_records with nb_pre = 1}) 
116 
::[compute_records_expr e]) 
117 
 Expr_appl (op_id, args, r) > 
118 
if List.mem op_id ops then 
119 
merge_records ( 
120 
({empty_records with nb_op = OpCount.singleton op_id 1}) 
121 
::[compute_records_expr args]) 
122 
else 
123 
compute_records_expr args 
124 
 _ > empty_records 
125 
in 
126 
merge_records [boolexpr;subrec] 
127  
128 
let compute_records_eq eq = compute_records_expr eq.eq_rhs 
129  
130 
let compute_records_node nd = 
131 
let eqs, auts = get_node_eqs nd in 
132 
assert (auts=[]); (* Automaton should be expanded by now *) 
133 
merge_records (List.map compute_records_eq eqs) 
134  
135 
let compute_records_top_decl td = 
136 
match td.top_decl_desc with 
137 
 Node nd > compute_records_node nd 
138 
 Const cst > compute_records_const_value cst.const_value 
139 
 _ > empty_records 
140  
141 
let compute_records prog = 
142 
merge_records (List.map compute_records_top_decl prog) 
143  
144 
(*****************************************************************) 
145 
(* Random mutation *) 
146 
(*****************************************************************) 
147  
148 
let check_mut e1 e2 = 
149 
let rec eq e1 e2 = 
150 
match e1.expr_desc, e2.expr_desc with 
151 
 Expr_const c1, Expr_const c2 > c1 = c2 
152 
 Expr_ident id1, Expr_ident id2 > id1 = id2 
153 
 Expr_tuple el1, Expr_tuple el2 > List.length el1 = List.length el2 && List.for_all2 eq el1 el2 
154 
 Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) > eq i1 i2 && eq t1 t2 && eq e1 e2 
155 
 Expr_arrow (x1, y1), Expr_arrow (x2, y2) > eq x1 x2 && eq y1 y2 
156 
 Expr_pre e1, Expr_pre e2 > eq e1 e2 
157 
 Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) > id1 = id2 && eq e1 e2 
158 
 _ > false 
159 
in 
160 
if not (eq e1 e2) then 
161 
Some (e1, e2) 
162 
else 
163 
None 
164  
165 
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c) 
166  
167 
let rdm_mutate_int i = 
168 
if Random.int 100 > threshold_inc_int then 
169 
i+1 
170 
else if Random.int 100 > threshold_dec_int then 
171 
i1 
172 
else if Random.int 100 > threshold_random_int then 
173 
Random.int 10 
174 
else if Random.int 100 > threshold_switch_int then 
175 
let idx = Random.int (List.length !int_consts) in 
176 
List.nth !int_consts idx 
177 
else 
178 
i 
179 

180 
let rdm_mutate_real r = 
181 
if Random.int 100 > threshold_random_float then 
182 
(* interval [0, bound] for random values *) 
183 
let bound = 10 in 
184 
(* max number of digits after comma *) 
185 
let digits = 5 in 
186 
(* number of digits after comma *) 
187 
let shift = Random.int (digits + 1) in 
188 
let eshift = 10. ** (float_of_int shift) in 
189 
let i = Random.int (1 + bound * (int_of_float eshift)) in 
190 
let f = float_of_int i /. eshift in 
191 
Real.create (string_of_int i) shift (string_of_float f) 
192 
else 
193 
r 
194  
195 
let rdm_mutate_op op = 
196 
match op with 
197 
 "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > 
198 
let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in 
199 
List.nth filtered (Random.int 3) 
200 
 "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op > 
201 
let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in 
202 
List.nth filtered (Random.int 3) 
203 
 "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op > 
204 
let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in 
205 
List.nth filtered (Random.int 5) 
206 
 _ > op 
207  
208  
209 
let rdm_mutate_var expr = 
210 
if Types.is_bool_type expr.expr_type then 
211 
(* if Random.int 100 > threshold_negate_bool_var then *) 
212 
let new_e = mkpredef_call expr.expr_loc "not" [expr] in 
213 
Some (expr, new_e), new_e 
214 
(* else *) 
215 
(* expr *) 
216 
else 
217 
None, expr 
218 

219 
let rdm_mutate_pre orig_expr = 
220 
let new_e = Expr_pre orig_expr in 
221 
Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e 
222  
223  
224 
let rdm_mutate_const_value c = 
225 
match c with 
226 
 Const_int i > Const_int (rdm_mutate_int i) 
227 
 Const_real r > Const_real (rdm_mutate_real r) 
228 
 Const_array _ 
229 
 Const_string _ 
230 
 Const_modeid _ 
231 
 Const_struct _ 
232 
 Const_tag _ > c 
233  
234 
let rdm_mutate_const c = 
235 
let new_const = rdm_mutate_const_value c.const_value in 
236 
let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in 
237 
mut, { c with const_value = new_const } 
238  
239  
240 
let select_in_list list rdm_mutate_elem = 
241 
let selected = Random.int (List.length list) in 
242 
let mutation_opt, new_list, _ = 
243 
List.fold_right 
244 
(fun elem (mutation_opt, res, cpt) > if cpt = selected then 
245 
let mutation, new_elem = rdm_mutate_elem elem in 
246 
Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1) 
247 
list 
248 
(None, [], 0) 
249 
in 
250 
match mutation_opt with 
251 
 Some mut > mut, new_list 
252 
 _ > assert false 
253  
254  
255 
let rec rdm_mutate_expr expr = 
256 
let mk_e d = { expr with expr_desc = d } in 
257 
match expr.expr_desc with 
258 
 Expr_ident id > rdm_mutate_var expr 
259 
 Expr_const c > 
260 
let new_const = rdm_mutate_const_value c in 
261 
let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in 
262 
mut, mk_e (Expr_const new_const) 
263 
 Expr_tuple l > 
264 
let mut, l' = select_in_list l rdm_mutate_expr in 
265 
mut, mk_e (Expr_tuple l') 
266 
 Expr_ite (i,t,e) > ( 
267 
let mut, l = select_in_list [i; t; e] rdm_mutate_expr in 
268 
match l with 
269 
 [i'; t'; e'] > mut, mk_e (Expr_ite (i', t', e')) 
270 
 _ > assert false 
271 
) 
272 
 Expr_arrow (e1, e2) > ( 
273 
let mut, l = select_in_list [e1; e2] rdm_mutate_expr in 
274 
match l with 
275 
 [e1'; e2'] > mut, mk_e (Expr_arrow (e1', e2')) 
276 
 _ > assert false 
277 
) 
278 
 Expr_pre e > 
279 
let select_pre = Random.bool () in 
280 
if select_pre then 
281 
let mut, new_expr = rdm_mutate_pre expr in 
282 
mut, mk_e new_expr 
283 
else 
284 
let mut, e' = rdm_mutate_expr e in 
285 
mut, mk_e (Expr_pre e') 
286 
 Expr_appl (op_id, args, r) > 
287 
let select_op = Random.bool () in 
288 
if select_op then 
289 
let new_op_id = rdm_mutate_op op_id in 
290 
let new_e = mk_e (Expr_appl (new_op_id, args, r)) in 
291 
let mut = check_mut expr new_e in 
292 
mut, new_e 
293 
else 
294 
let mut, new_args = rdm_mutate_expr args in 
295 
mut, mk_e (Expr_appl (op_id, new_args, r)) 
296 
(* Other constructs are kept. 
297 
 Expr_fby of expr * expr 
298 
 Expr_array of expr list 
299 
 Expr_access of expr * Dimension.dim_expr 
300 
 Expr_power of expr * Dimension.dim_expr 
301 
 Expr_when of expr * ident * label 
302 
 Expr_merge of ident * (label * expr) list 
303 
 Expr_uclock of expr * int 
304 
 Expr_dclock of expr * int 
305 
 Expr_phclock of expr * rat *) 
306 
 _ > None, expr 
307 

308  
309 
let rdm_mutate_eq eq = 
310 
let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in 
311 
mutation, { eq with eq_rhs = new_rhs } 
312  
313 
let rnd_mutate_stmt stmt = 
314 
match stmt with 
315 
 Eq eq > let mut, new_eq = rdm_mutate_eq eq in 
316 
report ~level:1 
317 
(fun fmt > fprintf fmt "mutation: %a becomes %a@ " 
318 
Printers.pp_node_eq eq 
319 
Printers.pp_node_eq new_eq); 
320 
mut, Eq new_eq 
321 
 Aut aut > assert false 
322  
323 
let rdm_mutate_node nd = 
324 
let mutation, new_node_stmts = 
325 
select_in_list 
326 
nd.node_stmts rnd_mutate_stmt 
327 
in 
328 
mutation, { nd with node_stmts = new_node_stmts } 
329  
330 
let rdm_mutate_top_decl td = 
331 
match td.top_decl_desc with 
332 
 Node nd > 
333 
let mutation, new_node = rdm_mutate_node nd in 
334 
mutation, { td with top_decl_desc = Node new_node} 
335 
 Const cst > 
336 
let mut, new_cst = rdm_mutate_const cst in 
337 
mut, { td with top_decl_desc = Const new_cst } 
338 
 _ > None, td 
339 

340 
(* Create a single mutant with the provided random seed *) 
341 
let rdm_mutate_prog prog = 
342 
select_in_list prog rdm_mutate_top_decl 
343  
344 
let rdm_mutate nb prog = 
345 
let rec iterate nb res = 
346 
incr random_seed; 
347 
if nb <= 0 then 
348 
res 
349 
else ( 
350 
Random.init !random_seed; 
351 
let mutation, new_mutant = rdm_mutate_prog prog in 
352 
match mutation with 
353 
None > iterate nb res 
354 
 Some mutation > ( 
355 
if List.mem_assoc mutation res then ( 
356 
iterate nb res 
357 
) 
358 
else ( 
359 
report ~level:1 (fun fmt > fprintf fmt "%i mutants remaining@ " nb); 
360 
iterate (nb1) ((mutation, new_mutant)::res) 
361 
) 
362 
) 
363 
) 
364 
in 
365 
iterate nb [] 
366  
367  
368 
(*****************************************************************) 
369 
(* Random mutation *) 
370 
(*****************************************************************) 
371  
372 
type mutant_t = 
373 
 Boolexpr of int 
374 
 Pre of int 
375 
 Op of string * int * string 
376 
 IncrIntCst of int 
377 
 DecrIntCst of int 
378 
 SwitchIntCst of int * int 
379  
380 
(* Denotes the parent node, the equation lhs and the location of the mutation *) 
381 
type mutation_loc = ident * ident list * Location.t 
382 
let target : mutant_t option ref = ref None 
383  
384 
let mutation_info : mutation_loc option ref = ref None 
385 
let current_node: ident option ref = ref None 
386 
let current_eq_lhs : ident list option ref = ref None 
387 
let current_loc : Location.t option ref = ref None 
388 

389 
let set_mutation_loc () = 
390 
target := None; 
391 
match !current_node, !current_eq_lhs, !current_loc with 
392 
 Some n, Some elhs, Some l > mutation_info := Some (n, elhs, l) 
393 
 _ > assert false (* Those global vars should be defined during the 
394 
visitor pattern execution *) 
395  
396 
let print_directive fmt d = 
397 
match d with 
398 
 Pre n > Format.fprintf fmt "pre %i" n 
399 
 Boolexpr n > Format.fprintf fmt "boolexpr %i" n 
400 
 Op (o, i, d) > Format.fprintf fmt "%s %i > %s" o i d 
401 
 IncrIntCst n > Format.fprintf fmt "incr int cst %i" n 
402 
 DecrIntCst n > Format.fprintf fmt "decr int cst %i" n 
403 
 SwitchIntCst (n, m) > Format.fprintf fmt "switch int cst %i > %i" n m 
404  
405 
let print_directive_json fmt d = 
406 
match d with 
407 
 Pre _ > Format.fprintf fmt "\"mutation\": \"pre\"" 
408 
 Boolexpr _ > Format.fprintf fmt "\"mutation\": \"not\"" 
409 
 Op (o, _, d) > Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d 
410 
 IncrIntCst n > Format.fprintf fmt "\"mutation\": \"cst_incr\"" 
411 
 DecrIntCst n > Format.fprintf fmt "\"mutation\": \"cst_decr\"" 
412 
 SwitchIntCst (n, m) > Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m 
413 

414 
let print_loc_json fmt (n,eqlhs, l) = 
415 
Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" 
416 
n 
417 
(Utils.fprintf_list ~sep:", " (fun fmt s > Format.fprintf fmt "\"%s\"" s)) eqlhs 
418 
(Location.loc_line l) 
419 

420 
let fold_mutate_int i = 
421 
if Random.int 100 > threshold_inc_int then 
422 
i+1 
423 
else if Random.int 100 > threshold_dec_int then 
424 
i1 
425 
else if Random.int 100 > threshold_random_int then 
426 
Random.int 10 
427 
else if Random.int 100 > threshold_switch_int then 
428 
try 
429 
let idx = Random.int (List.length !int_consts) in 
430 
List.nth !int_consts idx 
431 
with _ > i 
432 
else 
433 
i 
434 

435 
let fold_mutate_float f = 
436 
if Random.int 100 > threshold_random_float then 
437 
Random.float 10. 
438 
else 
439 
f 
440  
441 
let fold_mutate_op op = 
442 
(* match op with *) 
443 
(*  "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > *) 
444 
(* let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in *) 
445 
(* List.nth filtered (Random.int 3) *) 
446 
(*  "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op > *) 
447 
(* let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in *) 
448 
(* List.nth filtered (Random.int 3) *) 
449 
(*  "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op > *) 
450 
(* let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *) 
451 
(* List.nth filtered (Random.int 5) *) 
452 
(*  _ > op *) 
453 
match !target with 
454 
 Some (Op(op_orig, 0, op_new)) when op_orig = op > ( 
455 
set_mutation_loc (); 
456 
op_new 
457 
) 
458 
 Some (Op(op_orig, n, op_new)) when op_orig = op > ( 
459 
target := Some (Op(op_orig, n1, op_new)); 
460 
op 
461 
) 
462 
 _ > op 
463  
464  
465 
let fold_mutate_var expr = 
466 
(* match (Types.repr expr.expr_type).Types.tdesc with *) 
467 
(*  Types.Tbool > *) 
468 
(* (\* if Random.int 100 > threshold_negate_bool_var then *\) *) 
469 
(* mkpredef_unary_call Location.dummy_loc "not" expr *) 
470 
(* (\* else *\) *) 
471 
(* (\* expr *\) *) 
472 
(*  _ > 
473 
*)expr 
474  
475 
let fold_mutate_boolexpr expr = 
476 
match !target with 
477 
 Some (Boolexpr 0) > ( 
478 
set_mutation_loc (); 
479  
480 
mkpredef_call expr.expr_loc "not" [expr] 
481 
) 
482 
 Some (Boolexpr n) > 
483 
(target := Some (Boolexpr (n1)); expr) 
484 
 _ > expr 
485 

486 
let fold_mutate_pre orig_expr e = 
487 
match !target with 
488 
Some (Pre 0) > ( 
489 
set_mutation_loc (); 
490 
Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
491 
) 
492 
 Some (Pre n) > ( 
493 
target := Some (Pre (n1)); 
494 
Expr_pre e 
495 
) 
496 
 _ > Expr_pre e 
497 

498 
let fold_mutate_const_value c = 
499 
match c with 
500 
 Const_int i > ( 
501 
match !target with 
502 
 Some (IncrIntCst 0) > (set_mutation_loc (); Const_int (i+1)) 
503 
 Some (DecrIntCst 0) > (set_mutation_loc (); Const_int (i1)) 
504 
 Some (SwitchIntCst (0, id)) > 
505 
(set_mutation_loc (); Const_int id) 
506 
 Some (IncrIntCst n) > (target := Some (IncrIntCst (n1)); c) 
507 
 Some (DecrIntCst n) > (target := Some (DecrIntCst (n1)); c) 
508 
 Some (SwitchIntCst (n, id)) > (target := Some (SwitchIntCst (n1, id)); c) 
509 
 _ > c) 
510 
 _ > c 
511  
512 
(* 
513 
match c with 
514 
 Const_int i > Const_int (fold_mutate_int i) 
515 
 Const_real s > Const_real s (* those are string, let's leave them *) 
516 
 Const_float f > Const_float (fold_mutate_float f) 
517 
 Const_array _ 
518 
 Const_tag _ > c 
519 
TODO 
520  
521 
*) 
522 
let fold_mutate_const c = 
523 
{ c with const_value = fold_mutate_const_value c.const_value } 
524  
525 
let rec fold_mutate_expr expr = 
526 
current_loc := Some expr.expr_loc; 
527 
let new_expr = 
528 
match expr.expr_desc with 
529 
 Expr_ident id > fold_mutate_var expr 
530 
 _ > ( 
531 
let new_desc = match expr.expr_desc with 
532 
 Expr_const c > Expr_const (fold_mutate_const_value c) 
533 
 Expr_tuple l > Expr_tuple (List.fold_right (fun e res > (fold_mutate_expr e)::res) l []) 
534 
 Expr_ite (i,t,e) > Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e) 
535 
 Expr_arrow (e1, e2) > Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2) 
536 
 Expr_pre e > fold_mutate_pre expr (fold_mutate_expr e) 
537 
 Expr_appl (op_id, args, r) > Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r) 
538 
(* Other constructs are kept. 
539 
 Expr_fby of expr * expr 
540 
 Expr_array of expr list 
541 
 Expr_access of expr * Dimension.dim_expr 
542 
 Expr_power of expr * Dimension.dim_expr 
543 
 Expr_when of expr * ident * label 
544 
 Expr_merge of ident * (label * expr) list 
545 
 Expr_uclock of expr * int 
546 
 Expr_dclock of expr * int 
547 
 Expr_phclock of expr * rat *) 
548 
 _ > expr.expr_desc 
549 

550 
in 
551 
{ expr with expr_desc = new_desc } 
552 
) 
553 
in 
554 
if Types.is_bool_type expr.expr_type then 
555 
fold_mutate_boolexpr new_expr 
556 
else 
557 
new_expr 
558  
559 
let fold_mutate_eq eq = 
560 
current_eq_lhs := Some eq.eq_lhs; 
561 
{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs } 
562  
563 
let fold_mutate_stmt stmt = 
564 
match stmt with 
565 
 Eq eq > Eq (fold_mutate_eq eq) 
566 
 Aut aut > assert false 
567  
568  
569 
let fold_mutate_node nd = 
570 
current_node := Some nd.node_id; 
571 
let nd = 
572 
{ nd with 
573 
node_stmts = 
574 
List.fold_right (fun stmt res > (fold_mutate_stmt stmt)::res) nd.node_stmts []; 
575 
} 
576 
in 
577 
rename_node rename_app (fun x > x) nd 
578  
579 
let fold_mutate_top_decl td = 
580 
match td.top_decl_desc with 
581 
 Node nd > { td with top_decl_desc = Node (fold_mutate_node nd)} 
582 
 Const cst > { td with top_decl_desc = Const (fold_mutate_const cst)} 
583 
 _ > td 
584 

585 
(* Create a single mutant with the provided random seed *) 
586 
let fold_mutate_prog prog = 
587 
List.fold_right (fun e res > (fold_mutate_top_decl e)::res) prog [] 
588  
589 
let create_mutant prog directive = 
590 
target := Some directive; 
591 
let prog' = fold_mutate_prog prog in 
592 
let mutation_info = match !target , !mutation_info with 
593 
 None, Some mi > mi 
594 
 _ > ( 
595 
Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive; 
596 
let _ = match !target with Some dir' > Format.eprintf "New directive %a@.@?" print_directive dir'  _ > () in 
597 
assert false (* The mutation has not been performed. *) 
598 
) 
599 

600 
in 
601 
(* target := None; (* should happen only if no mutation occured during the 
602 
visit *)*) 
603 
prog', mutation_info 
604 

605  
606 
let op_mutation op = 
607 
let res = 
608 
let rem_op l = List.filter (fun e > e <> op) l in 
609 
if List.mem op arith_op then rem_op arith_op else 
610 
if List.mem op bool_op then rem_op bool_op else 
611 
if List.mem op rel_op then rem_op rel_op else 
612 
(Format.eprintf "Failing with op %s@." op; 
613 
assert false 
614 
) 
615 
in 
616 
(* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *) 
617 
res 
618  
619 
let rec remains select list = 
620 
match list with 
621 
[] > [] 
622 
 hd::tl > if select hd then tl else remains select tl 
623 

624 
let next_change m = 
625 
let res = 
626 
let rec first_op () = 
627 
try 
628 
let min_binding = OpCount.min_binding !records.nb_op in 
629 
Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding))) 
630 
with Not_found > first_boolexpr () 
631 
and first_boolexpr () = 
632 
if !records.nb_boolexpr > 0 then 
633 
Boolexpr 0 
634 
else first_pre () 
635 
and first_pre () = 
636 
if !records.nb_pre > 0 then 
637 
Pre 0 
638 
else 
639 
first_op () 
640 
and first_intcst () = 
641 
if IntSet.cardinal !records.consts > 0 then 
642 
IncrIntCst 0 
643 
else 
644 
first_boolexpr () 
645 
in 
646 
match m with 
647 
 Boolexpr n > 
648 
if n+1 >= !records.nb_boolexpr then 
649 
first_pre () 
650 
else 
651 
Boolexpr (n+1) 
652 
 Pre n > 
653 
if n+1 >= !records.nb_pre then 
654 
first_op () 
655 
else Pre (n+1) 
656 
 Op (orig, id, mut_op) > ( 
657 
match remains (fun x > x = mut_op) (op_mutation orig) with 
658 
 next_op::_ > Op (orig, id, next_op) 
659 
 [] > if id+1 >= OpCount.find orig !records.nb_op then ( 
660 
match remains (fun (k1, _) > k1 = orig) (OpCount.bindings !records.nb_op) with 
661 
 [] > first_intcst () 
662 
 hd::_ > Op (fst hd, 0, List.hd (op_mutation (fst hd))) 
663 
) else 
664 
Op(orig, id+1, List.hd (op_mutation orig)) 
665 
) 
666 
 IncrIntCst n > 
667 
if n+1 >= IntSet.cardinal !records.consts then 
668 
DecrIntCst 0 
669 
else IncrIntCst (n+1) 
670 
 DecrIntCst n > 
671 
if n+1 >= IntSet.cardinal !records.consts then 
672 
SwitchIntCst (0, 0) 
673 
else DecrIntCst (n+1) 
674 
 SwitchIntCst (n, m) > 
675 
if m+1 > 1 + IntSet.cardinal !records.consts then 
676 
SwitchIntCst (n, m+1) 
677 
else if n+1 >= IntSet.cardinal !records.consts then 
678 
SwitchIntCst (n+1, 0) 
679 
else first_boolexpr () 
680  
681 
in 
682 
(* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *) 
683 
res 
684  
685 
let fold_mutate nb prog = 
686 
incr random_seed; 
687 
Random.init !random_seed; 
688 
(* Local references to keep track of generated directives *) 
689  
690 
(* build a set of integer 0, 1, ... n1 for input n *) 
691 
let cpt_to_intset cpt = 
692 
let arr = Array.init cpt (fun x > x) in 
693 
Array.fold_right IntSet.add arr IntSet.empty 
694 
in 
695 

696 
let possible_const_id = cpt_to_intset !records.nb_consts in 
697 
(* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *) 
698 
(* let possible_pre_id = cpt_to_intset !records.nb_pre in *) 
699 

700 
let incremented_const_id = ref IntSet.empty in 
701 
let decremented_const_id = ref IntSet.empty in 
702 

703 
let create_new_incr_decr registered build = 
704 
let possible = IntSet.diff possible_const_id !registered > IntSet.elements in 
705 
let len = List.length possible in 
706 
if len <= 0 then 
707 
false, build (1) (* Should not be stored *) 
708 
else 
709 
let picked = List.nth possible (Random.int (List.length possible)) in 
710 
registered := IntSet.add picked !registered; 
711 
true, build picked 
712 
in 
713  
714  
715 
let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in 
716 
let switch_const_id = ref DblIntSet.empty in 
717 
let switch_set = 
718 
if IntSet.cardinal !records.consts <= 1 then 
719 
DblIntSet.empty 
720 
else 
721 
(* First element is cst id (the ith cst) while second is the 
722 
ith element of the set of gathered constants 
723 
!record.consts *) 
724 
IntSet.fold (fun cst_id set > 
725 
IntSet.fold (fun ith_cst set > 
726 
DblIntSet.add (cst_id, ith_cst) set 
727 
) !records.consts set 
728 
) possible_const_id DblIntSet.empty 
729 
in 
730  
731 
let create_new_switch registered build = 
732 
let possible = DblIntSet.diff switch_set !registered > DblIntSet.elements in 
733 
let len = List.length possible in 
734 
if len <= 0 then 
735 
false, build (1,1) (* Should not be stored *) 
736 
else 
737 
let picked = List.nth possible (Random.int (List.length possible)) in 
738 
registered := DblIntSet.add picked !registered; 
739 
true, build picked 
740 
in 
741 

742 
let find_next_new mutants mutant = 
743 
let rec find_next_new init current = 
744 
if init = current  List.mem current mutants then raise Not_found else 
745  
746 
(* TODO: check if we can generate more cases. The following lines were 
747 
cylcing and missing to detect that the enumaration was complete, 
748 
leading to a non terminating process. The current setting is harder 
749 
but may miss enumerating some cases. To be checked! *) 
750 

751 
(* if List.mem current mutants then *) 
752 
(* find_next_new init (next_change current) *) 
753 
(* else *) 
754 
current 
755 
in 
756 
find_next_new mutant (next_change mutant) 
757 
in 
758 
(* Creating list of nb elements of mutants *) 
759 
let rec create_mutants_directives rnb mutants = 
760 
if rnb <= 0 then mutants 
761 
else 
762 
(* Initial list of transformation *) 
763 
let rec init_list x = if x <= 0 then [0] else x::(init_list (x1)) in 
764 
let init_list = init_list 5 in 
765 
(* We generate a random permutation of the list: the first item is the 
766 
transformation, the rest of the list act as fallback choices to make 
767 
sure we produce something *) 
768 
let shuffle l = 
769 
let nd = List.map (fun c > Random.bits (), c) l in 
770 
let sond = List.sort compare nd in 
771 
List.map snd sond 
772 
in 
773 
let transforms = shuffle init_list in 
774 
let rec apply_transform transforms = 
775 
let f id = 
776 
match id with 
777 
 5 > create_new_incr_decr incremented_const_id (fun x > IncrIntCst x) 
778 
 4 > create_new_incr_decr decremented_const_id (fun x > DecrIntCst x) 
779 
 3 > create_new_switch switch_const_id (fun (x,y) > SwitchIntCst(x, y)) 
780 
 2 > !records.nb_pre >0, Pre (try Random.int !records.nb_pre with _ > 0) 
781 
 1 > !records.nb_boolexpr > 0, Boolexpr (try Random.int !records.nb_boolexpr with _ > 0) 
782 
 0 > let bindings = OpCount.bindings !records.nb_op in 
783 
let bindings_len = List.length bindings in 
784 
if bindings_len > 0 then 
785 
let op, nb_op = List.nth bindings (try Random.int bindings_len with _ > 0) in 
786 
let op_mut = op_mutation op in 
787 
let new_op = List.nth op_mut (try Random.int (List.length op_mut) with _ > 0) in 
788 
true, Op (op, (try Random.int nb_op with _ > 0), new_op) 
789 
else 
790 
false, Boolexpr 0 (* Providing a dummy construct, 
791 
it will be filtered out thanks 
792 
to the negative status (fst = 
793 
false) *) 
794 
 _ > assert false 
795 
in 
796 
match transforms with 
797 
 [] > assert false 
798 
 [hd] > f hd 
799 
 hd::tl > let ok, random_mutation = f hd in 
800 
if ok then 
801 
ok, random_mutation 
802 
else 
803 
apply_transform tl 
804 
in 
805 
let ok, random_mutation = apply_transform transforms in 
806 
let stop_process () = 
807 
report ~level:1 (fun fmt > fprintf fmt 
808 
"Only %i mutants directives generated out of %i expected@ " 
809 
(nbrnb) 
810 
nb); 
811 
mutants 
812 
in 
813 
if not ok then 
814 
stop_process () 
815 
else if List.mem random_mutation mutants then 
816 
try 
817 
let new_mutant = (find_next_new mutants random_mutation) in 
818 
report ~level:2 (fun fmt > fprintf fmt " %i mutants directive generated out of %i expected@ " (nbrnb) nb); 
819 
create_mutants_directives (rnb1) (new_mutant::mutants) 
820 
with Not_found > ( 
821 
stop_process () 
822 
) 
823 
else ( 
824 
create_mutants_directives (rnb1) (random_mutation::mutants) 
825 
) 
826 
in 
827 
let mutants_directives = create_mutants_directives nb [] in 
828 
List.map (fun d > 
829 
let mutant, loc = create_mutant prog d in 
830 
d, loc, mutant ) mutants_directives 
831 

832  
833 
let mutate nb prog = 
834 
records := compute_records prog; 
835 
(* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *) 
836 
(* !records.nb_pre *) 
837 
(* !records.nb_boolexpr *) 
838 
(* (\* !records.op *\) *) 
839 
(* ; *) 
840 
fold_mutate nb prog 
841  
842  
843  
844  
845 
(* Local Variables: *) 
846 
(* compilecommand:"make C .." *) 
847 
(* End: *) 
848  
849 
