Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 55a8633c

History | View | Annotate | Download (22.5 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
    i-1
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, l = select_in_list [i; t; e] rdm_mutate_expr in
241
    match l with
242
    | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e'))
243
    | _ -> assert false
244
  )
245
  | Expr_arrow (e1, e2) -> (
246
    let mut, l = select_in_list [e1; e2] rdm_mutate_expr in
247
    match l with
248
    | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2'))
249
    | _ -> assert false
250
  )
251
  | Expr_pre e -> 
252
    let select_pre = Random.bool () in
253
    if select_pre then
254
      let mut, new_expr = rdm_mutate_pre expr in
255
      mut, mk_e new_expr
256
    else
257
      let mut, e' = rdm_mutate_expr e in
258
      mut, mk_e (Expr_pre e')
259
  | Expr_appl (op_id, args, r) -> 
260
    let select_op = Random.bool () in
261
    if select_op then
262
      let new_op_id = rdm_mutate_op op_id in
263
      let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
264
      let mut = check_mut expr new_e in
265
      mut, new_e
266
    else
267
      let mut, new_args = rdm_mutate_expr args in
268
      mut, mk_e (Expr_appl (op_id, new_args, r))
269
  (* Other constructs are kept.
270
  | Expr_fby of expr * expr
271
  | Expr_array of expr list
272
  | Expr_access of expr * Dimension.dim_expr
273
  | Expr_power of expr * Dimension.dim_expr
274
  | Expr_when of expr * ident * label
275
  | Expr_merge of ident * (label * expr) list
276
  | Expr_uclock of expr * int
277
  | Expr_dclock of expr * int
278
  | Expr_phclock of expr * rat *)
279
   | _ -> None, expr
280
  
281

    
282
let rdm_mutate_eq eq =
283
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
284
  mutation, { eq with eq_rhs = new_rhs }
285

    
286
let rnd_mutate_stmt stmt =
287
  match stmt with
288
  | Eq eq   -> let mut, new_eq = rdm_mutate_eq eq in
289
		 report ~level:1 
290
		   (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
291
		     Printers.pp_node_eq eq
292
		     Printers.pp_node_eq new_eq);
293
		 mut, Eq new_eq 
294
  | Aut aut -> assert false
295

    
296
let rdm_mutate_node nd = 
297
  let mutation, new_node_stmts =       
298
    select_in_list 
299
      nd.node_stmts rnd_mutate_stmt
300
  in
301
  mutation, { nd with node_stmts = new_node_stmts }
302

    
303
let rdm_mutate_top_decl td =
304
  match td.top_decl_desc with
305
  | Node nd -> 
306
    let mutation, new_node = rdm_mutate_node nd in 
307
    mutation, { td with top_decl_desc = Node new_node}
308
  | Const cst -> 
309
    let mut, new_cst = rdm_mutate_const cst in
310
    mut, { td with top_decl_desc = Const new_cst }
311
  | _ -> None, td
312
    
313
(* Create a single mutant with the provided random seed *)
314
let rdm_mutate_prog prog = 
315
  select_in_list prog rdm_mutate_top_decl
316

    
317
let rdm_mutate nb prog = 
318
  let rec iterate nb res =
319
    incr random_seed;
320
    if nb <= 0 then
321
      res
322
    else (
323
      Random.init !random_seed;
324
      let mutation, new_mutant = rdm_mutate_prog prog in
325
      match mutation with
326
	None -> iterate nb res 
327
      | Some mutation -> ( 
328
	if List.mem_assoc mutation res then (
329
	  iterate nb res
330
	)
331
	else (
332
	  report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb); 
333
	  iterate (nb-1) ((mutation, new_mutant)::res)
334
	)
335
      )
336
    )
337
  in
338
  iterate nb []
339

    
340

    
341
(*****************************************************************)
342
(*                  Random mutation                              *)
343
(*****************************************************************)
344

    
345
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int 
346

    
347
(* Denotes the parent node, the equation lhs and the location of the mutation *)
348
type mutation_loc = ident * ident list * Location.t
349
let target : mutant_t option ref = ref None
350

    
351
let mutation_info : mutation_loc option ref = ref None
352
let current_node: ident option ref = ref None 
353
let current_eq_lhs : ident list option ref = ref None
354
let current_loc : Location.t option ref = ref None
355
  
356
let set_mutation_loc () =
357
  target := None;
358
  match !current_node, !current_eq_lhs, !current_loc with
359
  | Some n, Some elhs, Some l ->  mutation_info := Some (n, elhs, l)
360
  | _ -> assert false (* Those global vars should be defined during the
361
			   visitor pattern execution *)
362

    
363
let print_directive fmt d =
364
  match d with
365
  | Pre n -> Format.fprintf fmt "pre %i" n
366
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
367
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
368
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
369
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
370
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
371

    
372
let print_directive_json fmt d =
373
  match d with
374
  | Pre _ -> Format.fprintf fmt "\"mutation\": \"pre\""
375
  | Boolexpr _ -> Format.fprintf fmt "\"mutation\": \"not\"" 
376
  | Op (o, _, d) -> Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
377
  | IncrIntCst n ->  Format.fprintf fmt "\"mutation\": \"cst_incr\""
378
  | DecrIntCst n ->  Format.fprintf fmt "\"mutation\": \"cst_decr\""
379
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
380
  
381
let print_loc_json fmt (n,eqlhs, l) =
382
  Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\""
383
    n
384
    (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s)) eqlhs
385
    (Location.loc_line l)
386
    
387
let fold_mutate_int i = 
388
  if Random.int 100 > threshold_inc_int then
389
    i+1
390
  else if Random.int 100 > threshold_dec_int then
391
    i-1
392
  else if Random.int 100 > threshold_random_int then
393
    Random.int 10
394
  else if Random.int 100 > threshold_switch_int then
395
    try
396
	let idx = Random.int (List.length !int_consts) in
397
        List.nth !int_consts idx
398
    with _ -> i
399
  else
400
    i
401
  
402
let fold_mutate_float f =
403
  if Random.int 100 > threshold_random_float then
404
    Random.float 10.
405
  else 
406
    f
407

    
408
let fold_mutate_op op = 
409
(* match op with *)
410
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
411
(*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
412
(*   List.nth filtered (Random.int 3) *)
413
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
414
(*   let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
415
(*   List.nth filtered (Random.int 3) *)
416
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
417
(*   let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
418
(*   List.nth filtered (Random.int 5) *)
419
(* | _ -> op *)
420
  match !target with
421
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
422
    set_mutation_loc ();
423
    op_new
424
  )
425
  | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
426
    target := Some (Op(op_orig, n-1, op_new));
427
    op
428
  )
429
  | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op
430

    
431

    
432
let fold_mutate_var expr = 
433
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
434
  (* | Types.Tbool -> *)
435
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
436
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
437
  (*   (\* else  *\) *)
438
  (*   (\*   expr *\) *)
439
  (* | _ -> 
440
 *)expr
441

    
442
let fold_mutate_boolexpr expr =
443
  match !target with
444
  | Some (Boolexpr 0) -> (
445
     set_mutation_loc ();
446

    
447
    mkpredef_call expr.expr_loc "not" [expr]
448
  )
449
  | Some (Boolexpr n) ->
450
      (target := Some (Boolexpr (n-1)); expr)
451
  | _ -> expr
452
    
453
let fold_mutate_pre orig_expr e = 
454
  match !target with
455
    Some (Pre 0) -> (
456
      set_mutation_loc ();
457
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
458
    )
459
  | Some (Pre n) -> (
460
    target := Some (Pre (n-1));
461
    Expr_pre e
462
  )
463
  | _ -> Expr_pre e
464
    
465
let fold_mutate_const_value c = 
466
match c with
467
| Const_int i -> (
468
  match !target with
469
  | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
470
  | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
471
  | Some (SwitchIntCst (0, id)) -> (set_mutation_loc (); Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id)) 
472
  | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
473
  | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
474
  | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
475
  | _ -> c)
476
| _ -> c
477

    
478
(*
479
  match c with
480
  | Const_int i -> Const_int (fold_mutate_int i)
481
  | Const_real s -> Const_real s (* those are string, let's leave them *)
482
  | Const_float f -> Const_float (fold_mutate_float f)
483
  | Const_array _
484
  | Const_tag _ -> c
485
TODO
486

    
487
				  *)
488
let fold_mutate_const c =
489
  { c with const_value = fold_mutate_const_value c.const_value }
490

    
491
let rec fold_mutate_expr expr =
492
  current_loc := Some expr.expr_loc;
493
  let new_expr = 
494
    match expr.expr_desc with
495
    | Expr_ident id -> fold_mutate_var expr
496
    | _ -> (
497
      let new_desc = match expr.expr_desc with
498
	| Expr_const c -> Expr_const (fold_mutate_const_value c)
499
	| Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l [])
500
	| Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
501
	| Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
502
	| Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e)
503
	| Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
504
  (* Other constructs are kept.
505
  | Expr_fby of expr * expr
506
  | Expr_array of expr list
507
  | Expr_access of expr * Dimension.dim_expr
508
  | Expr_power of expr * Dimension.dim_expr
509
  | Expr_when of expr * ident * label
510
  | Expr_merge of ident * (label * expr) list
511
  | Expr_uclock of expr * int
512
  | Expr_dclock of expr * int
513
  | Expr_phclock of expr * rat *)
514
  | _ -> expr.expr_desc
515
    
516
      in
517
      { expr with expr_desc = new_desc }
518
    )
519
  in
520
  if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then
521
    fold_mutate_boolexpr new_expr  
522
  else
523
    new_expr
524

    
525
let fold_mutate_eq eq =
526
  current_eq_lhs := Some eq.eq_lhs;
527
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
528

    
529
let fold_mutate_stmt stmt =
530
  match stmt with
531
  | Eq eq   -> Eq (fold_mutate_eq eq)
532
  | Aut aut -> assert false
533

    
534
let fold_mutate_node nd =
535
  current_node := Some nd.node_id;
536
  { nd with 
537
    node_stmts = 
538
      List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
539
    node_id = rename_app nd.node_id
540
  }
541

    
542
let fold_mutate_top_decl td =
543
  match td.top_decl_desc with
544
  | Node nd   -> { td with top_decl_desc = Node  (fold_mutate_node nd)}
545
  | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
546
  | _ -> td
547
    
548
(* Create a single mutant with the provided random seed *)
549
let fold_mutate_prog prog = 
550
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
551

    
552
let create_mutant prog directive =  
553
  target := Some directive; 
554
  let prog' = fold_mutate_prog prog in
555
  let mutation_info = match !target , !mutation_info with
556
    | None, Some mi -> mi
557
    | _ -> assert false (* The mutation has not been performed. *)
558
     
559
  in
560
(*  target := None; (* should happen only if no mutation occured during the
561
    visit *)*)
562
  prog', mutation_info
563
  
564

    
565
let op_mutation op = 
566
  let res =
567
    let rem_op l = List.filter (fun e -> e <> op) l in
568
  if List.mem op arith_op then rem_op arith_op else 
569
    if List.mem op bool_op then rem_op bool_op else 
570
      if List.mem op rel_op then rem_op rel_op else 
571
	(Format.eprintf "Failing with op %s@." op;
572
	  assert false
573
	)
574
  in
575
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
576
  res
577

    
578
let rec remains select list =
579
  match list with 
580
    [] -> []
581
  | hd::tl -> if select hd then tl else remains select tl
582
      
583
let next_change m =
584
  let res = 
585
  let rec first_op () = 
586
    try
587
      let min_binding = OpCount.min_binding !records.nb_op in
588
      Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
589
    with Not_found -> first_boolexpr () 
590
  and first_boolexpr () =
591
    if !records.nb_boolexpr > 0 then 
592
      Boolexpr 0 
593
    else first_pre ()
594
  and first_pre () = 
595
    if !records.nb_pre > 0 then 
596
      Pre 0 
597
    else
598
      first_op ()
599
  and first_intcst () =
600
    if IntSet.cardinal !records.consts > 0 then
601
      IncrIntCst 0
602
    else
603
      first_boolexpr ()
604
  in
605
  match m with
606
  | Boolexpr n -> 
607
    if n+1 >= !records.nb_boolexpr then 
608
      first_pre ()
609
    else
610
      Boolexpr (n+1)
611
  | Pre n -> 
612
    if n+1 >= !records.nb_pre then 
613
      first_op ()
614
    else Pre (n+1)
615
  | Op (orig, id, mut_op) -> (
616
    match remains (fun x -> x = mut_op) (op_mutation orig) with
617
    | next_op::_ -> Op (orig, id, next_op)
618
    | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
619
      match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
620
      | [] -> first_intcst ()
621
      | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
622
    ) else
623
	Op(orig, id+1, List.hd (op_mutation orig))
624
  )
625
  | IncrIntCst n ->
626
    if n+1 >= IntSet.cardinal !records.consts then
627
      DecrIntCst 0
628
    else IncrIntCst (n+1)
629
  | DecrIntCst n ->
630
    if n+1 >= IntSet.cardinal !records.consts then
631
      SwitchIntCst (0, 0)
632
    else DecrIntCst (n+1)
633
  | SwitchIntCst (n, m) ->
634
    if m+1 > -1 + IntSet.cardinal !records.consts then
635
      SwitchIntCst (n, m+1)
636
    else if n+1 >= IntSet.cardinal !records.consts then
637
      SwitchIntCst (n+1, 0)
638
    else first_boolexpr ()
639

    
640
  in
641
  (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
642
  res
643

    
644
let fold_mutate nb prog = 
645
  incr random_seed;
646
  Random.init !random_seed;
647
  let find_next_new mutants mutant =
648
    let rec find_next_new init current =
649
      if init = current then raise Not_found else
650
	if List.mem current mutants then
651
	  find_next_new init (next_change current)
652
	else
653
	  current
654
    in
655
    find_next_new mutant (next_change mutant) 
656
  in
657
  (* Creating list of nb elements of mutants *)
658
  let rec create_mutants_directives rnb mutants = 
659
    if rnb <= 0 then mutants 
660
    else 
661
      let random_mutation = 
662
	match Random.int 6 with
663
	| 5 -> IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
664
	| 4 -> DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
665
	| 3 -> SwitchIntCst ((try Random.int (IntSet.cardinal !records.consts) with _ -> 0), (try Random.int (-1 + IntSet.cardinal !records.consts) with _ -> 0))
666
	| 2 -> Pre (try Random.int !records.nb_pre with _ -> 0)
667
	| 1 -> Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
668
	| 0 -> let bindings = OpCount.bindings !records.nb_op in
669
	       let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ -> 0) in
670
	       let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ -> 0) in
671
	       Op (op, (try Random.int nb_op with _ -> 0), new_op)
672
	| _ -> assert false
673
      in
674
      if List.mem random_mutation mutants then
675
	try
676
	  let new_mutant = (find_next_new mutants random_mutation) in
677
	  report ~level:2 (fun fmt -> fprintf fmt " %i mutants generated out of %i expected@." (nb-rnb) nb);
678
	 create_mutants_directives (rnb-1) (new_mutant::mutants) 
679
	with Not_found -> (
680
	  report ~level:1 (fun fmt -> fprintf fmt "Only %i mutants generated out of %i expected@." (nb-rnb) nb); 
681
	  mutants
682
	)
683
      else
684
	create_mutants_directives (rnb-1) (random_mutation::mutants)
685
  in
686
  let mutants_directives = create_mutants_directives nb [] in
687
  List.map (fun d ->
688
    let mutant, loc = create_mutant prog d in
689
    d, loc, mutant ) mutants_directives 
690
  
691

    
692
let mutate nb prog =
693
  records := compute_records prog;
694
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
695
  (*   !records.nb_pre *)
696
(*     !records.nb_boolexpr *)
697
(*     (\* !records.op *\) *)
698
(* ;  *)   
699
  fold_mutate nb prog 
700

    
701

    
702

    
703

    
704
(* Local Variables: *)
705
(* compile-command:"make -C .." *)
706
(* End: *)
707

    
708