Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 40d33d55

History | View | Annotate | Download (20.1 KB)

1
open Corelang
2
open Log
3
open Format
4

    
5
let random_seed = ref 0
6
let threshold_delay = 95
7
let threshold_inc_int = 97
8
let threshold_dec_int = 97
9
let threshold_random_int = 96
10
let threshold_switch_int = 100 (* not implemented yet *)
11
let threshold_random_float = 100 (* not used yet *)
12
let threshold_negate_bool_var = 95
13
let threshold_arith_op = 95
14
let threshold_rel_op = 95
15
let threshold_bool_op = 95
16

    
17
let int_consts = ref []
18

    
19
let rename_app id = 
20
  if !Options.no_mutation_suffix then
21
    id
22
  else
23
    id ^ "_mutant"
24

    
25
(************************************************************************************)
26
(*                    Gathering constants in the code                               *)
27
(************************************************************************************)
28

    
29
module IntSet = Set.Make (struct type t = int let compare = compare end)
30
module OpCount = Mmap.Make (struct type t = string let compare = compare end)
31

    
32
type records = {
33
  consts: IntSet.t;
34
  nb_boolexpr: int;
35
  nb_pre: int;
36
  nb_op: int OpCount.t;
37
}
38

    
39
let arith_op = ["+" ; "-" ; "*" ; "/"] 
40
let bool_op = ["&&"; "||"; "xor";  "impl"] 
41
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
42
let ops = arith_op @ bool_op @ rel_op
43
let all_ops = "not" :: ops
44

    
45
let empty_records = 
46
  {consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
47

    
48
let records = ref empty_records
49

    
50
let merge_records records_list = 
51
  let merge_record r1 r2 =
52
    {
53
      consts = IntSet.union r1.consts r2.consts;
54

    
55
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
56
      nb_pre = r1.nb_pre + r2.nb_pre;
57

    
58
      nb_op = OpCount.merge (fun op r1opt r2opt ->
59
	match r1opt, r2opt with
60
	| None, _ -> r2opt
61
	| _, None -> r1opt
62
	| Some x, Some y -> Some (x+y)
63
      ) r1.nb_op r2.nb_op 
64
    }
65
  in
66
  List.fold_left merge_record empty_records records_list
67
  
68
let compute_records_const_value c =
69
  match c with
70
  | Const_int i -> {empty_records with consts = IntSet.singleton i}
71
  | _ -> empty_records
72

    
73
let rec compute_records_expr expr =
74
  let boolexpr = 
75
    if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then
76
      {empty_records with nb_boolexpr = 1}
77
    else
78
      empty_records
79
  in
80
  let subrec = 
81
    match expr.expr_desc with
82
    | Expr_const c -> compute_records_const_value c
83
    | Expr_tuple l -> merge_records (List.map compute_records_expr l)
84
    | Expr_ite (i,t,e) -> 
85
      merge_records (List.map compute_records_expr [i;t;e])
86
    | Expr_arrow (e1, e2) ->       
87
      merge_records (List.map compute_records_expr [e1;e2])
88
    | Expr_pre e -> 
89
      merge_records (
90
	({empty_records with nb_pre = 1})
91
	::[compute_records_expr e])
92
    | Expr_appl (op_id, args, r) -> 
93
      if List.mem op_id ops then
94
	merge_records (
95
	  ({empty_records with nb_op = OpCount.singleton op_id 1})
96
	  ::[compute_records_expr args])
97
      else
98
	compute_records_expr args
99
    | _ -> empty_records
100
  in
101
  merge_records [boolexpr;subrec]
102

    
103
let compute_records_eq eq = compute_records_expr eq.eq_rhs
104

    
105
let compute_records_node nd = 
106
  merge_records (List.map compute_records_eq nd.node_eqs)
107

    
108
let compute_records_top_decl td =
109
  match td.top_decl_desc with
110
  | Node nd -> compute_records_node nd
111
  | Consts constsl -> merge_records (List.map (fun c -> compute_records_const_value c.const_value) constsl)
112
  | _ -> empty_records
113

    
114
let compute_records prog = 
115
  merge_records (List.map compute_records_top_decl prog)
116

    
117
(*****************************************************************)
118
(*                  Random mutation                              *)
119
(*****************************************************************)
120

    
121
let check_mut e1 e2 =
122
  let rec eq e1 e2 =
123
    match e1.expr_desc, e2.expr_desc with
124
    | Expr_const c1, Expr_const c2 -> c1 = c2
125
    | Expr_ident id1, Expr_ident id2 -> id1 = id2
126
    | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2
127
    | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2
128
    | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2
129
    | Expr_pre e1, Expr_pre e2 -> eq e1 e2
130
    | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2
131
  | _ -> false
132
  in
133
  if not (eq e1 e2) then
134
    Some (e1, e2)
135
  else
136
    None
137

    
138
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
139

    
140
let rdm_mutate_int i = 
141
  if Random.int 100 > threshold_inc_int then
142
    i+1
143
  else if Random.int 100 > threshold_dec_int then
144
    i-1
145
  else if Random.int 100 > threshold_random_int then
146
    Random.int 10
147
  else if Random.int 100 > threshold_switch_int then
148
    let idx = Random.int (List.length !int_consts) in
149
    List.nth !int_consts idx
150
  else
151
    i
152
  
153
let rdm_mutate_float f =
154
  if Random.int 100 > threshold_random_float then
155
    Random.float 10.
156
  else 
157
    f
158

    
159
let rdm_mutate_op op = 
160
match op with
161
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
162
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
163
  List.nth filtered (Random.int 3)
164
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
165
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
166
  List.nth filtered (Random.int 3)
167
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
168
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
169
  List.nth filtered (Random.int 5)
170
| _ -> op
171

    
172

    
173
let rdm_mutate_var expr = 
174
  match (Types.repr expr.expr_type).Types.tdesc with 
175
  | Types.Tbool ->
176
    (* if Random.int 100 > threshold_negate_bool_var then *)
177
    let new_e = mkpredef_unary_call Location.dummy_loc "not" expr in
178
    Some (expr, new_e), new_e
179
    (* else  *)
180
    (*   expr *)
181
  | _ -> None, expr
182
    
183
let rdm_mutate_pre orig_expr = 
184
  let new_e = Expr_pre orig_expr in
185
  Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e
186

    
187

    
188
let rdm_mutate_const_value c =
189
  match c with
190
  | Const_int i -> Const_int (rdm_mutate_int i)
191
  | Const_real s ->  Const_real s (* those are string, let's leave them *)
192
  | Const_float f -> Const_float (rdm_mutate_float f)
193
  | Const_array _
194
  | Const_tag _ -> c
195

    
196
let rdm_mutate_const c =
197
  let new_const = rdm_mutate_const_value c.const_value in
198
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
199
  mut, { c with const_value = new_const }
200

    
201

    
202
let select_in_list list rdm_mutate_elem = 
203
  let selected = Random.int (List.length list) in
204
  let mutation_opt, new_list, _ = 
205
    List.fold_right
206
      (fun elem (mutation_opt, res, cpt) -> if cpt = selected then 
207
	  let mutation, new_elem = rdm_mutate_elem elem in
208
	  Some mutation, new_elem::res, cpt+1  else mutation_opt, elem::res, cpt+1)
209
      list 
210
      (None, [], 0)
211
  in
212
  match mutation_opt with
213
  | Some mut -> mut, new_list
214
  | _ -> assert false
215

    
216

    
217
let rec rdm_mutate_expr expr =
218
  let mk_e d = { expr with expr_desc = d } in
219
  match expr.expr_desc with
220
  | Expr_ident id -> rdm_mutate_var expr
221
  | Expr_const c -> 
222
    let new_const = rdm_mutate_const_value c in 
223
    let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
224
    mut, mk_e (Expr_const new_const)
225
  | Expr_tuple l -> 
226
    let mut, l' = select_in_list l rdm_mutate_expr in
227
    mut, mk_e (Expr_tuple l')
228
  | Expr_ite (i,t,e) -> 
229
    let mut, [i'; t'; e'] = select_in_list [i; t; e] rdm_mutate_expr in
230
    mut, mk_e (Expr_ite (i', t', e'))
231
  | Expr_arrow (e1, e2) -> 
232
    let mut, [e1'; e2'] = select_in_list [e1; e2] rdm_mutate_expr in
233
    mut, mk_e (Expr_arrow (e1', e2'))
234
  | Expr_pre e -> 
235
    let select_pre = Random.bool () in
236
    if select_pre then
237
      let mut, new_expr = rdm_mutate_pre expr in
238
      mut, mk_e new_expr
239
    else
240
      let mut, e' = rdm_mutate_expr e in
241
      mut, mk_e (Expr_pre e')
242
  | Expr_appl (op_id, args, r) -> 
243
    let select_op = Random.bool () in
244
    if select_op then
245
      let new_op_id = rdm_mutate_op op_id in
246
      let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
247
      let mut = check_mut expr new_e in
248
      mut, new_e
249
    else
250
      let mut, new_args = rdm_mutate_expr args in
251
      mut, mk_e (Expr_appl (op_id, new_args, r))
252
	
253
  (* Other constructs are kept.
254
  | Expr_fby of expr * expr
255
  | Expr_array of expr list
256
  | Expr_access of expr * Dimension.dim_expr
257
  | Expr_power of expr * Dimension.dim_expr
258
  | Expr_when of expr * ident * label
259
  | Expr_merge of ident * (label * expr) list
260
  | Expr_uclock of expr * int
261
  | Expr_dclock of expr * int
262
  | Expr_phclock of expr * rat *)
263
  (* | _ -> expr.expr_desc *)
264
  
265

    
266
let rdm_mutate_eq eq =
267
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
268
  mutation, { eq with eq_rhs = new_rhs }
269

    
270
let rdm_mutate_node nd = 
271
  let mutation, new_node_eqs =       
272
    select_in_list 
273
      nd.node_eqs 
274
      (fun eq -> let mut, new_eq = rdm_mutate_eq eq in
275
		 report ~level:1 
276
		   (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
277
		     Printers.pp_node_eq eq
278
		     Printers.pp_node_eq new_eq);
279
		 mut, new_eq )
280
  in
281
  mutation, { nd with node_eqs = new_node_eqs }
282

    
283
let rdm_mutate_top_decl td =
284
  match td.top_decl_desc with
285
  | Node nd -> 
286
    let mutation, new_node = rdm_mutate_node nd in 
287
    mutation, { td with top_decl_desc = Node new_node}
288
  | Consts constsl -> 
289
    let mut, new_constsl = select_in_list constsl rdm_mutate_const in
290
    mut, { td with top_decl_desc = Consts new_constsl }
291
  | _ -> None, td
292
    
293
(* Create a single mutant with the provided random seed *)
294
let rdm_mutate_prog prog = 
295
  select_in_list prog rdm_mutate_top_decl
296

    
297
let rdm_mutate nb prog = 
298
  let rec iterate nb res =
299
    incr random_seed;
300
    if nb <= 0 then
301
      res
302
    else (
303
      Random.init !random_seed;
304
      let mutation, new_mutant = rdm_mutate_prog prog in
305
      match mutation with
306
	None -> iterate nb res 
307
      | Some mutation -> ( 
308
	if List.mem_assoc mutation res then (
309
	  iterate nb res
310
	)
311
	else (
312
	  report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb); 
313
	  iterate (nb-1) ((mutation, new_mutant)::res)
314
	)
315
      )
316
    )
317
  in
318
  iterate nb []
319

    
320

    
321
(*****************************************************************)
322
(*                  Random mutation                              *)
323
(*****************************************************************)
324

    
325
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int 
326

    
327
let target : mutant_t option ref = ref None
328

    
329
let print_directive fmt d =
330
  match d with
331
  | Pre n -> Format.fprintf fmt "pre %i" n
332
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
333
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
334
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
335
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
336
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
337

    
338
let fold_mutate_int i = 
339
  if Random.int 100 > threshold_inc_int then
340
    i+1
341
  else if Random.int 100 > threshold_dec_int then
342
    i-1
343
  else if Random.int 100 > threshold_random_int then
344
    Random.int 10
345
  else if Random.int 100 > threshold_switch_int then
346
    try
347
	let idx = Random.int (List.length !int_consts) in
348
        List.nth !int_consts idx
349
    with _ -> i
350
  else
351
    i
352
  
353
let fold_mutate_float f =
354
  if Random.int 100 > threshold_random_float then
355
    Random.float 10.
356
  else 
357
    f
358

    
359
let fold_mutate_op op = 
360
(* match op with *)
361
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
362
(*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
363
(*   List.nth filtered (Random.int 3) *)
364
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
365
(*   let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
366
(*   List.nth filtered (Random.int 3) *)
367
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
368
(*   let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
369
(*   List.nth filtered (Random.int 5) *)
370
(* | _ -> op *)
371
  match !target with
372
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
373
    target := None;
374
    op_new
375
  )
376
  | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
377
    target := Some (Op(op_orig, n-1, op_new));
378
    op
379
  )
380
  | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op
381

    
382

    
383
let fold_mutate_var expr = 
384
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
385
  (* | Types.Tbool -> *)
386
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
387
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
388
  (*   (\* else  *\) *)
389
  (*   (\*   expr *\) *)
390
  (* | _ -> 
391
 *)expr
392

    
393
let fold_mutate_boolexpr expr =
394
  match !target with
395
  | Some (Boolexpr 0) -> (
396
    target := None;
397
    mkpredef_unary_call Location.dummy_loc "not" expr
398
  )
399
  | Some (Boolexpr n) ->
400
      (target := Some (Boolexpr (n-1)); expr)
401
  | _ -> expr
402
    
403
let fold_mutate_pre orig_expr e = 
404
  match !target with
405
    Some (Pre 0) -> (
406
      target := None;
407
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
408
    )
409
  | Some (Pre n) -> (
410
    target := Some (Pre (n-1));
411
    Expr_pre e
412
  )
413
  | _ -> Expr_pre e
414
    
415
let fold_mutate_const_value c = 
416
match c with
417
| Const_int i -> (
418
  match !target with
419
  | Some (IncrIntCst 0) -> (target := None; Const_int (i+1))
420
  | Some (DecrIntCst 0) -> (target := None; Const_int (i-1))
421
  | Some (SwitchIntCst (0, id)) -> (target := None; Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id)) 
422
  | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
423
  | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
424
  | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
425
  | _ -> c)
426
| _ -> c
427

    
428
(*
429
  match c with
430
  | Const_int i -> Const_int (fold_mutate_int i)
431
  | Const_real s -> Const_real s (* those are string, let's leave them *)
432
  | Const_float f -> Const_float (fold_mutate_float f)
433
  | Const_array _
434
  | Const_tag _ -> c
435
TODO
436

    
437
				  *)
438
let fold_mutate_const c =
439
  { c with const_value = fold_mutate_const_value c.const_value }
440

    
441
let rec fold_mutate_expr expr =
442
  let new_expr = 
443
    match expr.expr_desc with
444
    | Expr_ident id -> fold_mutate_var expr
445
    | _ -> (
446
      let new_desc = match expr.expr_desc with
447
	| Expr_const c -> Expr_const (fold_mutate_const_value c)
448
	| Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l [])
449
	| Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
450
	| Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
451
	| Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e)
452
	| Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
453
  (* Other constructs are kept.
454
  | Expr_fby of expr * expr
455
  | Expr_array of expr list
456
  | Expr_access of expr * Dimension.dim_expr
457
  | Expr_power of expr * Dimension.dim_expr
458
  | Expr_when of expr * ident * label
459
  | Expr_merge of ident * (label * expr) list
460
  | Expr_uclock of expr * int
461
  | Expr_dclock of expr * int
462
  | Expr_phclock of expr * rat *)
463
  | _ -> expr.expr_desc
464
    
465
      in
466
      { expr with expr_desc = new_desc }
467
    )
468
  in
469
  if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then
470
    fold_mutate_boolexpr new_expr  
471
  else
472
    new_expr
473

    
474
let fold_mutate_eq eq =
475
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
476

    
477
let fold_mutate_node nd = 
478
  { nd with 
479
    node_eqs = 
480
      List.fold_right (fun e res -> (fold_mutate_eq e)::res) nd.node_eqs [];
481
    node_id = rename_app nd.node_id
482
  }
483

    
484
let fold_mutate_top_decl td =
485
  match td.top_decl_desc with
486
  | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)}
487
  | Consts constsl -> { td with top_decl_desc = Consts (List.fold_right (fun e res -> (fold_mutate_const e)::res) constsl [])}
488
  | _ -> td
489
    
490
(* Create a single mutant with the provided random seed *)
491
let fold_mutate_prog prog = 
492
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
493

    
494
let create_mutant prog directive =  
495
  target := Some directive; 
496
  let prog' = fold_mutate_prog prog in
497
  target := None;
498
  prog'
499
  
500

    
501
let op_mutation op = 
502
  let res =
503
    let rem_op l = List.filter (fun e -> e <> op) l in
504
  if List.mem op arith_op then rem_op arith_op else 
505
    if List.mem op bool_op then rem_op bool_op else 
506
      if List.mem op rel_op then rem_op rel_op else 
507
	(Format.eprintf "Failing with op %s@." op;
508
	  assert false
509
	)
510
  in
511
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
512
  res
513

    
514
let rec remains select list =
515
  match list with 
516
    [] -> []
517
  | hd::tl -> if select hd then tl else remains select tl
518
      
519
let next_change m =
520
  let res = 
521
  let rec first_op () = 
522
    try
523
      let min_binding = OpCount.min_binding !records.nb_op in
524
      Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
525
    with Not_found -> first_boolexpr () 
526
  and first_boolexpr () =
527
    if !records.nb_boolexpr > 0 then 
528
      Boolexpr 0 
529
    else first_pre ()
530
  and first_pre () = 
531
    if !records.nb_pre > 0 then 
532
      Pre 0 
533
    else
534
      first_op ()
535
  and first_intcst () =
536
    if IntSet.cardinal !records.consts > 0 then
537
      IncrIntCst 0
538
    else
539
      first_boolexpr ()
540
  in
541
  match m with
542
  | Boolexpr n -> 
543
    if n+1 >= !records.nb_boolexpr then 
544
      first_pre ()
545
    else
546
      Boolexpr (n+1)
547
  | Pre n -> 
548
    if n+1 >= !records.nb_pre then 
549
      first_op ()
550
    else Pre (n+1)
551
  | Op (orig, id, mut_op) -> (
552
    match remains (fun x -> x = mut_op) (op_mutation orig) with
553
    | next_op::_ -> Op (orig, id, next_op)
554
    | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
555
      match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
556
      | [] -> first_intcst ()
557
      | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
558
    ) else
559
	Op(orig, id+1, List.hd (op_mutation orig))
560
  )
561
  | IncrIntCst n ->
562
    if n+1 >= IntSet.cardinal !records.consts then
563
      DecrIntCst 0
564
    else IncrIntCst (n+1)
565
  | DecrIntCst n ->
566
    if n+1 >= IntSet.cardinal !records.consts then
567
      SwitchIntCst (0, 0)
568
    else DecrIntCst (n+1)
569
  | SwitchIntCst (n, m) ->
570
    if m+1 > -1 + IntSet.cardinal !records.consts then
571
      SwitchIntCst (n, m+1)
572
    else if n+1 >= IntSet.cardinal !records.consts then
573
      SwitchIntCst (n+1, 0)
574
    else first_boolexpr ()
575

    
576
  in
577
  (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
578
  res
579

    
580
let fold_mutate nb prog = 
581
  incr random_seed;
582
  Random.init !random_seed;
583
  let find_next_new mutants mutant =
584
    let rec find_next_new init current =
585
      if init = current then raise Not_found else
586
	if List.mem current mutants then
587
	  find_next_new init (next_change current)
588
	else
589
	  current
590
    in
591
    find_next_new mutant (next_change mutant) 
592
  in
593
  (* Creating list of nb elements of mutants *)
594
  let rec create_mutants_directives rnb mutants = 
595
    if rnb <= 0 then mutants 
596
    else 
597
      let random_mutation = 
598
	match Random.int 6 with
599
	| 5 -> IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
600
	| 4 -> DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
601
	| 3 -> SwitchIntCst ((try Random.int (IntSet.cardinal !records.consts) with _ -> 0), (try Random.int (-1 + IntSet.cardinal !records.consts) with _ -> 0))
602
	| 2 -> Pre (try Random.int !records.nb_pre with _ -> 0)
603
	| 1 -> Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
604
	| 0 -> let bindings = OpCount.bindings !records.nb_op in
605
	       let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ -> 0) in
606
	       let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ -> 0) in
607
	       Op (op, (try Random.int nb_op with _ -> 0), new_op)
608
	| _ -> assert false
609
      in
610
      if List.mem random_mutation mutants then
611
	try
612
	  let new_mutant = (find_next_new mutants random_mutation) in
613
	  report ~level:2 (fun fmt -> fprintf fmt " %i mutants generated out of %i expected@." (nb-rnb) nb);
614
	 create_mutants_directives (rnb-1) (new_mutant::mutants) 
615
	with Not_found -> (
616
	  report ~level:1 (fun fmt -> fprintf fmt "Only %i mutants generated out of %i expected@." (nb-rnb) nb); 
617
	  mutants
618
	)
619
      else
620
	create_mutants_directives (rnb-1) (random_mutation::mutants)
621
  in
622
  let mutants_directives = create_mutants_directives nb [] in
623
  List.map (fun d -> d, create_mutant prog d) mutants_directives 
624
  
625

    
626
let mutate nb prog =
627
  records := compute_records prog;
628
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
629
  (*   !records.nb_pre *)
630
(*     !records.nb_boolexpr *)
631
(*     (\* !records.op *\) *)
632
(* ;  *)   
633
  fold_mutate nb prog, print_directive
634

    
635

    
636

    
637

    
638
(* Local Variables: *)
639
(* compile-command:"make -C .." *)
640
(* End: *)
641

    
642