Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 7ecfca04

History | View | Annotate | Download (20.5 KB)

1
open Corelang
2
open LustreSpec
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_stmt s =
107
  match s with
108
  | Eq eq -> compute_records_expr eq.eq_rhs
109
  | _ -> empty_records (* Automata should have been desintegrate by now *)
110

    
111
let compute_records_node nd = 
112
  merge_records (List.map compute_records_stmt nd.node_stmts)
113

    
114
let compute_records_top_decl td =
115
  match td.top_decl_desc with
116
  | Node nd -> compute_records_node nd
117
  | Const const -> compute_records_const_value const.const_value
118
  | _ -> empty_records
119

    
120
let compute_records prog = 
121
  merge_records (List.map compute_records_top_decl prog)
122

    
123
(*****************************************************************)
124
(*                  Random mutation                              *)
125
(*****************************************************************)
126

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

    
144
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
145

    
146
let rdm_mutate_int i = 
147
  if Random.int 100 > threshold_inc_int then
148
    i+1
149
  else if Random.int 100 > threshold_dec_int then
150
    i-1
151
  else if Random.int 100 > threshold_random_int then
152
    Random.int 10
153
  else if Random.int 100 > threshold_switch_int then
154
    let idx = Random.int (List.length !int_consts) in
155
    List.nth !int_consts idx
156
  else
157
    i
158
  
159
let rdm_mutate_float f =
160
  if Random.int 100 > threshold_random_float then
161
    Random.float 10.
162
  else 
163
    f
164

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

    
178

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

    
193

    
194
let rdm_mutate_const_value c =
195
  match c with
196
  | Const_int i -> Const_int (rdm_mutate_int i)
197
  | Const_real (num, npow, s) as c ->  c
198
  (* OTOD: mutation disable here, should look at rdm_mutate_float f and adapt it *)
199
  | Const_array _
200
  | Const_tag _
201
  | Const_string _
202
  |Const_struct _  -> c
203

    
204
let rdm_mutate_const c =
205
  let new_const = rdm_mutate_const_value c.const_value in
206
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
207
  mut, { c with const_value = new_const }
208

    
209

    
210
let select_in_list list rdm_mutate_elem = 
211
  let selected = Random.int (List.length list) in
212
  let mutation_opt, new_list, _ = 
213
    List.fold_right
214
      (fun elem (mutation_opt, res, cpt) -> if cpt = selected then 
215
	  let mutation, new_elem = rdm_mutate_elem elem in
216
	  Some mutation, new_elem::res, cpt+1  else mutation_opt, elem::res, cpt+1)
217
      list 
218
      (None, [], 0)
219
  in
220
  match mutation_opt with
221
  | Some mut -> mut, new_list
222
  | _ -> assert false
223

    
224

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

    
274
let rdm_mutate_eq eq =
275
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
276
  mutation, { eq with eq_rhs = new_rhs }
277

    
278
let rdm_mutate_node nd = 
279
  let mutation, new_node_stmts =
280
    select_in_list 
281
      nd.node_stmts 
282
      (fun stmt ->match stmt with
283
      | Eq eq -> let mut, new_eq = rdm_mutate_eq eq in
284
		  report ~level:1 
285
		    (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
286
		      Printers.pp_node_eq eq
287
		      Printers.pp_node_eq new_eq);
288
		  mut, Eq new_eq
289
      | _ -> assert false (* shold have been removed by now *) )
290
  in
291
  mutation, { nd with node_stmts = new_node_stmts }
292

    
293
let rdm_mutate_top_decl td =
294
  match td.top_decl_desc with
295
  | Node nd -> 
296
    let mutation, new_node = rdm_mutate_node nd in 
297
    mutation, { td with top_decl_desc = Node new_node}
298
  | Const const -> 
299
    let mut, new_const = rdm_mutate_const const in
300
    mut, { td with top_decl_desc = Const new_const }
301
  | _ -> None, td
302
    
303
(* Create a single mutant with the provided random seed *)
304
let rdm_mutate_prog prog = 
305
  select_in_list prog rdm_mutate_top_decl
306

    
307
let rdm_mutate nb prog = 
308
  let rec iterate nb res =
309
    incr random_seed;
310
    if nb <= 0 then
311
      res
312
    else (
313
      Random.init !random_seed;
314
      let mutation, new_mutant = rdm_mutate_prog prog in
315
      match mutation with
316
	None -> iterate nb res 
317
      | Some mutation -> ( 
318
	if List.mem_assoc mutation res then (
319
	  iterate nb res
320
	)
321
	else (
322
	  report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb); 
323
	  iterate (nb-1) ((mutation, new_mutant)::res)
324
	)
325
      )
326
    )
327
  in
328
  iterate nb []
329

    
330

    
331
(*****************************************************************)
332
(*                  Random mutation                              *)
333
(*****************************************************************)
334

    
335
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int 
336

    
337
let target : mutant_t option ref = ref None
338

    
339
let print_directive fmt d =
340
  match d with
341
  | Pre n -> Format.fprintf fmt "pre %i" n
342
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
343
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
344
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
345
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
346
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
347

    
348
let fold_mutate_int i = 
349
  if Random.int 100 > threshold_inc_int then
350
    i+1
351
  else if Random.int 100 > threshold_dec_int then
352
    i-1
353
  else if Random.int 100 > threshold_random_int then
354
    Random.int 10
355
  else if Random.int 100 > threshold_switch_int then
356
    try
357
	let idx = Random.int (List.length !int_consts) in
358
        List.nth !int_consts idx
359
    with _ -> i
360
  else
361
    i
362
  
363
let fold_mutate_float f =
364
  if Random.int 100 > threshold_random_float then
365
    Random.float 10.
366
  else 
367
    f
368

    
369
let fold_mutate_op op = 
370
(* match op with *)
371
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
372
(*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
373
(*   List.nth filtered (Random.int 3) *)
374
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
375
(*   let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
376
(*   List.nth filtered (Random.int 3) *)
377
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
378
(*   let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
379
(*   List.nth filtered (Random.int 5) *)
380
(* | _ -> op *)
381
  match !target with
382
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
383
    target := None;
384
    op_new
385
  )
386
  | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
387
    target := Some (Op(op_orig, n-1, op_new));
388
    op
389
  )
390
  | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op
391

    
392

    
393
let fold_mutate_var expr = 
394
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
395
  (* | Types.Tbool -> *)
396
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
397
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
398
  (*   (\* else  *\) *)
399
  (*   (\*   expr *\) *)
400
  (* | _ -> 
401
 *)expr
402

    
403
let fold_mutate_boolexpr expr =
404
  match !target with
405
  | Some (Boolexpr 0) -> (
406
    target := None;
407
    mkpredef_unary_call Location.dummy_loc "not" expr
408
  )
409
  | Some (Boolexpr n) ->
410
      (target := Some (Boolexpr (n-1)); expr)
411
  | _ -> expr
412
    
413
let fold_mutate_pre orig_expr e = 
414
  match !target with
415
    Some (Pre 0) -> (
416
      target := None;
417
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
418
    )
419
  | Some (Pre n) -> (
420
    target := Some (Pre (n-1));
421
    Expr_pre e
422
  )
423
  | _ -> Expr_pre e
424
    
425
let fold_mutate_const_value c = 
426
match c with
427
| Const_int i -> (
428
  match !target with
429
  | Some (IncrIntCst 0) -> (target := None; Const_int (i+1))
430
  | Some (DecrIntCst 0) -> (target := None; Const_int (i-1))
431
  | Some (SwitchIntCst (0, id)) -> (target := None; Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id)) 
432
  | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
433
  | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
434
  | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
435
  | _ -> c)
436
| _ -> c
437

    
438
(*
439
  match c with
440
  | Const_int i -> Const_int (fold_mutate_int i)
441
  | Const_real s -> Const_real s (* those are string, let's leave them *)
442
  | Const_float f -> Const_float (fold_mutate_float f)
443
  | Const_array _
444
  | Const_tag _ -> c
445
TODO
446

    
447
				  *)
448
let fold_mutate_const c =
449
  { c with const_value = fold_mutate_const_value c.const_value }
450

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

    
484
let fold_mutate_eq eq =
485
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
486

    
487
let fold_mutate_stmt s =
488
  match s with
489
  | Eq eq -> Eq { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
490
  | _ -> assert false (* should have been removed by now *)
491

    
492
let fold_mutate_node nd = 
493
  { nd with 
494
    node_stmts = 
495
      List.fold_right (fun e res -> (fold_mutate_stmt e)::res) nd.node_stmts [];
496
    node_id = rename_app nd.node_id
497
  }
498

    
499
let fold_mutate_top_decl td =
500
  match td.top_decl_desc with
501
  | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)}
502
  | Const const -> { td with top_decl_desc = Const (fold_mutate_const const)}
503
  | _ -> td
504
    
505
(* Create a single mutant with the provided random seed *)
506
let fold_mutate_prog prog = 
507
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
508

    
509
let create_mutant prog directive =  
510
  target := Some directive; 
511
  let prog' = fold_mutate_prog prog in
512
  target := None;
513
  prog'
514
  
515

    
516
let op_mutation op = 
517
  let res =
518
    let rem_op l = List.filter (fun e -> e <> op) l in
519
  if List.mem op arith_op then rem_op arith_op else 
520
    if List.mem op bool_op then rem_op bool_op else 
521
      if List.mem op rel_op then rem_op rel_op else 
522
	(Format.eprintf "Failing with op %s@." op;
523
	  assert false
524
	)
525
  in
526
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
527
  res
528

    
529
let rec remains select list =
530
  match list with 
531
    [] -> []
532
  | hd::tl -> if select hd then tl else remains select tl
533
      
534
let next_change m =
535
  let res = 
536
  let rec first_op () = 
537
    try
538
      let min_binding = OpCount.min_binding !records.nb_op in
539
      Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
540
    with Not_found -> first_boolexpr () 
541
  and first_boolexpr () =
542
    if !records.nb_boolexpr > 0 then 
543
      Boolexpr 0 
544
    else first_pre ()
545
  and first_pre () = 
546
    if !records.nb_pre > 0 then 
547
      Pre 0 
548
    else
549
      first_op ()
550
  and first_intcst () =
551
    if IntSet.cardinal !records.consts > 0 then
552
      IncrIntCst 0
553
    else
554
      first_boolexpr ()
555
  in
556
  match m with
557
  | Boolexpr n -> 
558
    if n+1 >= !records.nb_boolexpr then 
559
      first_pre ()
560
    else
561
      Boolexpr (n+1)
562
  | Pre n -> 
563
    if n+1 >= !records.nb_pre then 
564
      first_op ()
565
    else Pre (n+1)
566
  | Op (orig, id, mut_op) -> (
567
    match remains (fun x -> x = mut_op) (op_mutation orig) with
568
    | next_op::_ -> Op (orig, id, next_op)
569
    | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
570
      match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
571
      | [] -> first_intcst ()
572
      | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
573
    ) else
574
	Op(orig, id+1, List.hd (op_mutation orig))
575
  )
576
  | IncrIntCst n ->
577
    if n+1 >= IntSet.cardinal !records.consts then
578
      DecrIntCst 0
579
    else IncrIntCst (n+1)
580
  | DecrIntCst n ->
581
    if n+1 >= IntSet.cardinal !records.consts then
582
      SwitchIntCst (0, 0)
583
    else DecrIntCst (n+1)
584
  | SwitchIntCst (n, m) ->
585
    if m+1 > -1 + IntSet.cardinal !records.consts then
586
      SwitchIntCst (n, m+1)
587
    else if n+1 >= IntSet.cardinal !records.consts then
588
      SwitchIntCst (n+1, 0)
589
    else first_boolexpr ()
590

    
591
  in
592
  (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
593
  res
594

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

    
641
let mutate nb prog =
642
  records := compute_records prog;
643
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
644
  (*   !records.nb_pre *)
645
(*     !records.nb_boolexpr *)
646
(*     (\* !records.op *\) *)
647
(* ;  *)   
648
  fold_mutate nb prog, print_directive
649

    
650

    
651

    
652

    
653
(* Local Variables: *)
654
(* compile-command:"make -C .." *)
655
(* End: *)
656

    
657