Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 0d54d8a8

History | View | Annotate | Download (26.4 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
  let node = Corelang.node_from_name id in
34
  let is_imported =
35
    match node.top_decl_desc with
36
    | ImportedNode _ -> true
37
    | _ -> false
38
  in
39
  if !Options.no_mutation_suffix || is_imported then
40
    id
41
  else
42
    id ^ "_mutant"
43

    
44
(************************************************************************************)
45
(*                    Gathering constants in the code                               *)
46
(************************************************************************************)
47

    
48
module IntSet = Set.Make (struct type t = int let compare = compare end)
49
module OpCount = Mmap.Make (struct type t = string let compare = compare end)
50

    
51
type records = {
52
  consts: IntSet.t;
53
  nb_consts: int;
54
  nb_boolexpr: int;
55
  nb_pre: int;
56
  nb_op: int OpCount.t;
57
}
58

    
59
let arith_op = ["+" ; "-" ; "*" ; "/"] 
60
let bool_op = ["&&"; "||"; "xor";  "impl"] 
61
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
62
let ops = arith_op @ bool_op @ rel_op
63
let all_ops = "not" :: ops
64

    
65
let empty_records = 
66
  {consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
67

    
68
let records = ref empty_records
69

    
70
let merge_records records_list = 
71
  let merge_record r1 r2 =
72
    {
73
      consts = IntSet.union r1.consts r2.consts;
74

    
75
      nb_consts = r1.nb_consts + r2.nb_consts;
76
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
77
      nb_pre = r1.nb_pre + r2.nb_pre;
78

    
79
      nb_op = OpCount.merge (fun op r1opt r2opt ->
80
	match r1opt, r2opt with
81
	| None, _ -> r2opt
82
	| _, None -> r1opt
83
	| Some x, Some y -> Some (x+y)
84
      ) r1.nb_op r2.nb_op 
85
    }
86
  in
87
  List.fold_left merge_record empty_records records_list
88
  
89
let compute_records_const_value c =
90
  match c with
91
  | Const_int i -> {empty_records with consts = IntSet.singleton i; nb_consts = 1}
92
  | _ -> empty_records
93

    
94
let rec compute_records_expr expr =
95
  let boolexpr = 
96
    if Types.is_bool_type expr.expr_type then
97
      {empty_records with nb_boolexpr = 1}
98
    else
99
      empty_records
100
  in
101
  let subrec = 
102
    match expr.expr_desc with
103
    | Expr_const c -> compute_records_const_value c
104
    | Expr_tuple l -> merge_records (List.map compute_records_expr l)
105
    | Expr_ite (i,t,e) -> 
106
      merge_records (List.map compute_records_expr [i;t;e])
107
    | Expr_arrow (e1, e2) ->       
108
      merge_records (List.map compute_records_expr [e1;e2])
109
    | Expr_pre e -> 
110
      merge_records (
111
	({empty_records with nb_pre = 1})
112
	::[compute_records_expr e])
113
    | Expr_appl (op_id, args, r) -> 
114
      if List.mem op_id ops then
115
	merge_records (
116
	  ({empty_records with nb_op = OpCount.singleton op_id 1})
117
	  ::[compute_records_expr args])
118
      else
119
	compute_records_expr args
120
    | _ -> empty_records
121
  in
122
  merge_records [boolexpr;subrec]
123

    
124
let compute_records_eq eq = compute_records_expr eq.eq_rhs
125

    
126
let compute_records_node nd =
127
  let eqs, auts = get_node_eqs nd in
128
  assert (auts=[]); (* Automaton should be expanded by now *)
129
  merge_records (List.map compute_records_eq eqs)
130

    
131
let compute_records_top_decl td =
132
  match td.top_decl_desc with
133
  | Node nd -> compute_records_node nd
134
  | Const cst -> compute_records_const_value cst.const_value
135
  | _ -> empty_records
136

    
137
let compute_records prog = 
138
  merge_records (List.map compute_records_top_decl prog)
139

    
140
(*****************************************************************)
141
(*                  Random mutation                              *)
142
(*****************************************************************)
143

    
144
let check_mut e1 e2 =
145
  let rec eq e1 e2 =
146
    match e1.expr_desc, e2.expr_desc with
147
    | Expr_const c1, Expr_const c2 -> c1 = c2
148
    | Expr_ident id1, Expr_ident id2 -> id1 = id2
149
    | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2
150
    | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2
151
    | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2
152
    | Expr_pre e1, Expr_pre e2 -> eq e1 e2
153
    | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2
154
  | _ -> false
155
  in
156
  if not (eq e1 e2) then
157
    Some (e1, e2)
158
  else
159
    None
160

    
161
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
162

    
163
let rdm_mutate_int i = 
164
  if Random.int 100 > threshold_inc_int then
165
    i+1
166
  else if Random.int 100 > threshold_dec_int then
167
    i-1
168
  else if Random.int 100 > threshold_random_int then
169
    Random.int 10
170
  else if Random.int 100 > threshold_switch_int then
171
    let idx = Random.int (List.length !int_consts) in
172
    List.nth !int_consts idx
173
  else
174
    i
175
  
176
let rdm_mutate_real r =
177
  if Random.int 100 > threshold_random_float then
178
    (* interval [0, bound] for random values *)
179
    let bound = 10 in
180
    (* max number of digits after comma *)
181
    let digits = 5 in
182
    (* number of digits after comma *)
183
    let shift = Random.int (digits + 1) in
184
    let eshift = 10. ** (float_of_int shift) in
185
    let i = Random.int (1 + bound * (int_of_float eshift)) in
186
    let f = float_of_int i /. eshift in
187
    (Num.num_of_int i, shift, string_of_float f)
188
  else 
189
    r
190

    
191
let rdm_mutate_op op = 
192
match op with
193
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
194
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
195
  List.nth filtered (Random.int 3)
196
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
197
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
198
  List.nth filtered (Random.int 3)
199
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
200
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
201
  List.nth filtered (Random.int 5)
202
| _ -> op
203

    
204

    
205
let rdm_mutate_var expr =
206
  if Types.is_bool_type expr.expr_type then
207
    (* if Random.int 100 > threshold_negate_bool_var then *)
208
    let new_e = mkpredef_call expr.expr_loc "not" [expr] in
209
    Some (expr, new_e), new_e
210
    (* else  *)
211
  (*   expr *)
212
  else
213
    None, expr
214
    
215
let rdm_mutate_pre orig_expr = 
216
  let new_e = Expr_pre orig_expr in
217
  Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e
218

    
219

    
220
let rdm_mutate_const_value c =
221
  match c with
222
  | Const_int i -> Const_int (rdm_mutate_int i)
223
  | Const_real (n, i, s) -> let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s')
224
  | Const_array _
225
  | Const_string _
226
  | Const_modeid _
227
  | Const_struct _
228
  | Const_tag _ -> c
229

    
230
let rdm_mutate_const c =
231
  let new_const = rdm_mutate_const_value c.const_value in
232
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
233
  mut, { c with const_value = new_const }
234

    
235

    
236
let select_in_list list rdm_mutate_elem = 
237
  let selected = Random.int (List.length list) in
238
  let mutation_opt, new_list, _ = 
239
    List.fold_right
240
      (fun elem (mutation_opt, res, cpt) -> if cpt = selected then 
241
	  let mutation, new_elem = rdm_mutate_elem elem in
242
	  Some mutation, new_elem::res, cpt+1  else mutation_opt, elem::res, cpt+1)
243
      list 
244
      (None, [], 0)
245
  in
246
  match mutation_opt with
247
  | Some mut -> mut, new_list
248
  | _ -> assert false
249

    
250

    
251
let rec rdm_mutate_expr expr =
252
  let mk_e d = { expr with expr_desc = d } in
253
  match expr.expr_desc with
254
  | Expr_ident id -> rdm_mutate_var expr
255
  | Expr_const c -> 
256
    let new_const = rdm_mutate_const_value c in 
257
    let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
258
    mut, mk_e (Expr_const new_const)
259
  | Expr_tuple l -> 
260
    let mut, l' = select_in_list l rdm_mutate_expr in
261
    mut, mk_e (Expr_tuple l')
262
  | Expr_ite (i,t,e) -> (
263
    let mut, l = select_in_list [i; t; e] rdm_mutate_expr in
264
    match l with
265
    | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e'))
266
    | _ -> assert false
267
  )
268
  | Expr_arrow (e1, e2) -> (
269
    let mut, l = select_in_list [e1; e2] rdm_mutate_expr in
270
    match l with
271
    | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2'))
272
    | _ -> assert false
273
  )
274
  | Expr_pre e -> 
275
    let select_pre = Random.bool () in
276
    if select_pre then
277
      let mut, new_expr = rdm_mutate_pre expr in
278
      mut, mk_e new_expr
279
    else
280
      let mut, e' = rdm_mutate_expr e in
281
      mut, mk_e (Expr_pre e')
282
  | Expr_appl (op_id, args, r) -> 
283
    let select_op = Random.bool () in
284
    if select_op then
285
      let new_op_id = rdm_mutate_op op_id in
286
      let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
287
      let mut = check_mut expr new_e in
288
      mut, new_e
289
    else
290
      let mut, new_args = rdm_mutate_expr args in
291
      mut, mk_e (Expr_appl (op_id, new_args, r))
292
  (* Other constructs are kept.
293
  | Expr_fby of expr * expr
294
  | Expr_array of expr list
295
  | Expr_access of expr * Dimension.dim_expr
296
  | Expr_power of expr * Dimension.dim_expr
297
  | Expr_when of expr * ident * label
298
  | Expr_merge of ident * (label * expr) list
299
  | Expr_uclock of expr * int
300
  | Expr_dclock of expr * int
301
  | Expr_phclock of expr * rat *)
302
   | _ -> None, expr
303
  
304

    
305
let rdm_mutate_eq eq =
306
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
307
  mutation, { eq with eq_rhs = new_rhs }
308

    
309
let rnd_mutate_stmt stmt =
310
  match stmt with
311
  | Eq eq   -> let mut, new_eq = rdm_mutate_eq eq in
312
		 report ~level:1 
313
		   (fun fmt -> fprintf fmt "mutation: %a becomes %a@ " 
314
		     Printers.pp_node_eq eq
315
		     Printers.pp_node_eq new_eq);
316
		 mut, Eq new_eq 
317
  | Aut aut -> assert false
318

    
319
let rdm_mutate_node nd = 
320
  let mutation, new_node_stmts =       
321
    select_in_list 
322
      nd.node_stmts rnd_mutate_stmt
323
  in
324
  mutation, { nd with node_stmts = new_node_stmts }
325

    
326
let rdm_mutate_top_decl td =
327
  match td.top_decl_desc with
328
  | Node nd -> 
329
    let mutation, new_node = rdm_mutate_node nd in 
330
    mutation, { td with top_decl_desc = Node new_node}
331
  | Const cst -> 
332
    let mut, new_cst = rdm_mutate_const cst in
333
    mut, { td with top_decl_desc = Const new_cst }
334
  | _ -> None, td
335
    
336
(* Create a single mutant with the provided random seed *)
337
let rdm_mutate_prog prog = 
338
  select_in_list prog rdm_mutate_top_decl
339

    
340
let rdm_mutate nb prog = 
341
  let rec iterate nb res =
342
    incr random_seed;
343
    if nb <= 0 then
344
      res
345
    else (
346
      Random.init !random_seed;
347
      let mutation, new_mutant = rdm_mutate_prog prog in
348
      match mutation with
349
	None -> iterate nb res 
350
      | Some mutation -> ( 
351
	if List.mem_assoc mutation res then (
352
	  iterate nb res
353
	)
354
	else (
355
	  report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb); 
356
	  iterate (nb-1) ((mutation, new_mutant)::res)
357
	)
358
      )
359
    )
360
  in
361
  iterate nb []
362

    
363

    
364
(*****************************************************************)
365
(*                  Random mutation                              *)
366
(*****************************************************************)
367

    
368
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int 
369

    
370
(* Denotes the parent node, the equation lhs and the location of the mutation *)
371
type mutation_loc = ident * ident list * Location.t
372
let target : mutant_t option ref = ref None
373

    
374
let mutation_info : mutation_loc option ref = ref None
375
let current_node: ident option ref = ref None 
376
let current_eq_lhs : ident list option ref = ref None
377
let current_loc : Location.t option ref = ref None
378
  
379
let set_mutation_loc () =
380
  target := None;
381
  match !current_node, !current_eq_lhs, !current_loc with
382
  | Some n, Some elhs, Some l ->  mutation_info := Some (n, elhs, l)
383
  | _ -> assert false (* Those global vars should be defined during the
384
			   visitor pattern execution *)
385

    
386
let print_directive fmt d =
387
  match d with
388
  | Pre n -> Format.fprintf fmt "pre %i" n
389
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
390
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
391
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
392
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
393
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
394

    
395
let print_directive_json fmt d =
396
  match d with
397
  | Pre _ -> Format.fprintf fmt "\"mutation\": \"pre\""
398
  | Boolexpr _ -> Format.fprintf fmt "\"mutation\": \"not\"" 
399
  | Op (o, _, d) -> Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
400
  | IncrIntCst n ->  Format.fprintf fmt "\"mutation\": \"cst_incr\""
401
  | DecrIntCst n ->  Format.fprintf fmt "\"mutation\": \"cst_decr\""
402
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
403
  
404
let print_loc_json fmt (n,eqlhs, l) =
405
  Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\""
406
    n
407
    (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s)) eqlhs
408
    (Location.loc_line l)
409
    
410
let fold_mutate_int i = 
411
  if Random.int 100 > threshold_inc_int then
412
    i+1
413
  else if Random.int 100 > threshold_dec_int then
414
    i-1
415
  else if Random.int 100 > threshold_random_int then
416
    Random.int 10
417
  else if Random.int 100 > threshold_switch_int then
418
    try
419
	let idx = Random.int (List.length !int_consts) in
420
        List.nth !int_consts idx
421
    with _ -> i
422
  else
423
    i
424
  
425
let fold_mutate_float f =
426
  if Random.int 100 > threshold_random_float then
427
    Random.float 10.
428
  else 
429
    f
430

    
431
let fold_mutate_op op = 
432
(* match op with *)
433
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
434
(*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
435
(*   List.nth filtered (Random.int 3) *)
436
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
437
(*   let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
438
(*   List.nth filtered (Random.int 3) *)
439
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
440
(*   let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
441
(*   List.nth filtered (Random.int 5) *)
442
(* | _ -> op *)
443
  match !target with
444
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
445
    set_mutation_loc ();
446
    op_new
447
  )
448
  | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
449
    target := Some (Op(op_orig, n-1, op_new));
450
    op
451
  )
452
  | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op
453

    
454

    
455
let fold_mutate_var expr = 
456
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
457
  (* | Types.Tbool -> *)
458
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
459
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
460
  (*   (\* else  *\) *)
461
  (*   (\*   expr *\) *)
462
  (* | _ -> 
463
 *)expr
464

    
465
let fold_mutate_boolexpr expr =
466
  match !target with
467
  | Some (Boolexpr 0) -> (
468
     set_mutation_loc ();
469

    
470
    mkpredef_call expr.expr_loc "not" [expr]
471
  )
472
  | Some (Boolexpr n) ->
473
      (target := Some (Boolexpr (n-1)); expr)
474
  | _ -> expr
475
    
476
let fold_mutate_pre orig_expr e = 
477
  match !target with
478
    Some (Pre 0) -> (
479
      set_mutation_loc ();
480
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
481
    )
482
  | Some (Pre n) -> (
483
    target := Some (Pre (n-1));
484
    Expr_pre e
485
  )
486
  | _ -> Expr_pre e
487
    
488
let fold_mutate_const_value c = 
489
match c with
490
| Const_int i -> (
491
  match !target with
492
  | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
493
  | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
494
  | Some (SwitchIntCst (0, id)) ->
495
     (set_mutation_loc (); Const_int id) 
496
  | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
497
  | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
498
  | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
499
  | _ -> c)
500
| _ -> c
501

    
502
(*
503
  match c with
504
  | Const_int i -> Const_int (fold_mutate_int i)
505
  | Const_real s -> Const_real s (* those are string, let's leave them *)
506
  | Const_float f -> Const_float (fold_mutate_float f)
507
  | Const_array _
508
  | Const_tag _ -> c
509
TODO
510

    
511
				  *)
512
let fold_mutate_const c =
513
  { c with const_value = fold_mutate_const_value c.const_value }
514

    
515
let rec fold_mutate_expr expr =
516
  current_loc := Some expr.expr_loc;
517
  let new_expr = 
518
    match expr.expr_desc with
519
    | Expr_ident id -> fold_mutate_var expr
520
    | _ -> (
521
      let new_desc = match expr.expr_desc with
522
	| Expr_const c -> Expr_const (fold_mutate_const_value c)
523
	| Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l [])
524
	| Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
525
	| Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
526
	| Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e)
527
	| Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
528
  (* Other constructs are kept.
529
  | Expr_fby of expr * expr
530
  | Expr_array of expr list
531
  | Expr_access of expr * Dimension.dim_expr
532
  | Expr_power of expr * Dimension.dim_expr
533
  | Expr_when of expr * ident * label
534
  | Expr_merge of ident * (label * expr) list
535
  | Expr_uclock of expr * int
536
  | Expr_dclock of expr * int
537
  | Expr_phclock of expr * rat *)
538
  | _ -> expr.expr_desc
539
    
540
      in
541
      { expr with expr_desc = new_desc }
542
    )
543
  in
544
  if Types.is_bool_type expr.expr_type then
545
    fold_mutate_boolexpr new_expr  
546
  else
547
    new_expr
548

    
549
let fold_mutate_eq eq =
550
  current_eq_lhs := Some eq.eq_lhs;
551
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
552

    
553
let fold_mutate_stmt stmt =
554
  match stmt with
555
  | Eq eq   -> Eq (fold_mutate_eq eq)
556
  | Aut aut -> assert false
557

    
558
let fold_mutate_node nd =
559
  current_node := Some nd.node_id;
560
  { nd with 
561
    node_stmts = 
562
      List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
563
    node_id = rename_app nd.node_id
564
  }
565

    
566
let fold_mutate_top_decl td =
567
  match td.top_decl_desc with
568
  | Node nd   -> { td with top_decl_desc = Node  (fold_mutate_node nd)}
569
  | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
570
  | _ -> td
571
    
572
(* Create a single mutant with the provided random seed *)
573
let fold_mutate_prog prog = 
574
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
575

    
576
let create_mutant prog directive =  
577
  target := Some directive; 
578
  let prog' = fold_mutate_prog prog in
579
  let mutation_info = match !target , !mutation_info with
580
    | None, Some mi -> mi
581
    | _ -> (
582
      Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive;
583
      let _ = match !target with Some dir' -> Format.eprintf "New directive %a@.@?" print_directive dir' | _ -> () in
584
      assert false (* The mutation has not been performed. *)
585
    )
586
     
587
  in
588
(*  target := None; (* should happen only if no mutation occured during the
589
    visit *)*)
590
  prog', mutation_info
591
  
592

    
593
let op_mutation op = 
594
  let res =
595
    let rem_op l = List.filter (fun e -> e <> op) l in
596
  if List.mem op arith_op then rem_op arith_op else 
597
    if List.mem op bool_op then rem_op bool_op else 
598
      if List.mem op rel_op then rem_op rel_op else 
599
	(Format.eprintf "Failing with op %s@." op;
600
	  assert false
601
	)
602
  in
603
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
604
  res
605

    
606
let rec remains select list =
607
  match list with 
608
    [] -> []
609
  | hd::tl -> if select hd then tl else remains select tl
610
      
611
let next_change m =
612
  let res = 
613
  let rec first_op () = 
614
    try
615
      let min_binding = OpCount.min_binding !records.nb_op in
616
      Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
617
    with Not_found -> first_boolexpr () 
618
  and first_boolexpr () =
619
    if !records.nb_boolexpr > 0 then 
620
      Boolexpr 0 
621
    else first_pre ()
622
  and first_pre () = 
623
    if !records.nb_pre > 0 then 
624
      Pre 0 
625
    else
626
      first_op ()
627
  and first_intcst () =
628
    if IntSet.cardinal !records.consts > 0 then
629
      IncrIntCst 0
630
    else
631
      first_boolexpr ()
632
  in
633
  match m with
634
  | Boolexpr n -> 
635
    if n+1 >= !records.nb_boolexpr then 
636
      first_pre ()
637
    else
638
      Boolexpr (n+1)
639
  | Pre n -> 
640
    if n+1 >= !records.nb_pre then 
641
      first_op ()
642
    else Pre (n+1)
643
  | Op (orig, id, mut_op) -> (
644
    match remains (fun x -> x = mut_op) (op_mutation orig) with
645
    | next_op::_ -> Op (orig, id, next_op)
646
    | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
647
      match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
648
      | [] -> first_intcst ()
649
      | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
650
    ) else
651
	Op(orig, id+1, List.hd (op_mutation orig))
652
  )
653
  | IncrIntCst n ->
654
    if n+1 >= IntSet.cardinal !records.consts then
655
      DecrIntCst 0
656
    else IncrIntCst (n+1)
657
  | DecrIntCst n ->
658
    if n+1 >= IntSet.cardinal !records.consts then
659
      SwitchIntCst (0, 0)
660
    else DecrIntCst (n+1)
661
  | SwitchIntCst (n, m) ->
662
    if m+1 > -1 + IntSet.cardinal !records.consts then
663
      SwitchIntCst (n, m+1)
664
    else if n+1 >= IntSet.cardinal !records.consts then
665
      SwitchIntCst (n+1, 0)
666
    else first_boolexpr ()
667

    
668
  in
669
   (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res;  *)
670
  res
671

    
672
let fold_mutate nb prog = 
673
  incr random_seed;
674
  Random.init !random_seed;
675
  (* Local references to keep track of generated directives *)
676

    
677
  (* build a set of integer 0, 1, ... n-1 for input n *)
678
  let cpt_to_intset cpt =
679
    let arr = Array.init cpt (fun x -> x) in
680
    Array.fold_right IntSet.add arr IntSet.empty
681
  in
682
  
683
  let possible_const_id = cpt_to_intset !records.nb_consts in
684
  (* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)
685
  (* let possible_pre_id = cpt_to_intset !records.nb_pre in *)
686
  
687
  let incremented_const_id = ref IntSet.empty in
688
  let decremented_const_id = ref IntSet.empty in
689
  
690
  let create_new_incr_decr registered build =
691
    let possible = IntSet.diff possible_const_id !registered |> IntSet.elements in
692
    let len = List.length possible in
693
    if len <= 0 then
694
      false, build (-1) (* Should not be stored *)
695
    else
696
      let picked = List.nth possible (Random.int (List.length possible)) in
697
      registered := IntSet.add picked !registered;
698
      true, build picked
699
  in
700

    
701

    
702
  let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in
703
  let switch_const_id = ref DblIntSet.empty in
704
  let switch_set =
705
    if IntSet.cardinal !records.consts <= 1 then
706
      DblIntSet.empty
707
    else
708
      (* First element is cst id (the ith cst) while second is the
709
		       ith element of the set of gathered constants
710
		       !record.consts *)
711
      IntSet.fold (fun cst_id set ->
712
	IntSet.fold (fun ith_cst set ->
713
	  DblIntSet.add (cst_id, ith_cst) set
714
	) !records.consts set
715
      ) possible_const_id DblIntSet.empty 
716
  in
717

    
718
  let create_new_switch registered build =
719
    let possible = DblIntSet.diff switch_set !registered |> DblIntSet.elements in
720
    let len = List.length possible in
721
    if len <= 0 then
722
      false, build (-1,-1) (* Should not be stored *)
723
    else
724
      let picked = List.nth possible (Random.int (List.length possible)) in
725
      registered := DblIntSet.add picked !registered;
726
      true, build picked
727
  in
728
  
729
  let find_next_new mutants mutant =
730
    let rec find_next_new init current =
731
      if init = current || List.mem current mutants then raise Not_found else
732

    
733
	(* TODO: check if we can generate more cases. The following lines were
734
	   cylcing and missing to detect that the enumaration was complete,
735
	   leading to a non terminating process. The current setting is harder
736
	   but may miss enumerating some cases. To be checked! *)
737
	
738
	(* if List.mem current mutants then *)
739
	(*   find_next_new init (next_change current) *)
740
	(* else *)
741
	current
742
    in
743
    find_next_new mutant (next_change mutant) 
744
  in
745
  (* Creating list of nb elements of mutants *)
746
  let rec create_mutants_directives rnb mutants = 
747
    if rnb <= 0 then mutants 
748
    else
749
      (* Initial list of transformation *)
750
      let rec init_list x = if x <= 0 then [0] else x::(init_list (x-1)) in
751
      let init_list = init_list 5 in
752
      (* We generate a random permutation of the list: the first item is the
753
	 transformation, the rest of the list act as fallback choices to make
754
	 sure we produce something *)
755
      let shuffle l =
756
	let nd = List.map (fun c -> Random.bits (), c) l in
757
	let sond = List.sort compare nd in
758
	List.map snd sond
759
      in
760
      let transforms = shuffle init_list in
761
      let rec apply_transform transforms =
762
	let f id = 
763
	  match id with
764
	  | 5 -> create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x)
765
	  | 4 -> create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x)
766
	  | 3 -> create_new_switch switch_const_id (fun (x,y) -> SwitchIntCst(x, y))
767
	  | 2 -> !records.nb_pre >0, Pre (try Random.int !records.nb_pre with _ -> 0)
768
	  | 1 -> !records.nb_boolexpr > 0, Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
769
	  | 0 -> let bindings = OpCount.bindings !records.nb_op in
770
		 let bindings_len = List.length bindings in
771
		 let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ -> 0) in
772
		 let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ -> 0) in
773
	         bindings_len > 0, Op (op, (try Random.int nb_op with _ -> 0), new_op)
774
	  | _ -> assert false
775
	in
776
	match transforms with
777
	| [] -> assert false
778
	| [hd] -> f hd
779
	| hd::tl -> let ok, random_mutation = f hd in
780
		    if ok then
781
		      ok, random_mutation
782
		    else
783
		      apply_transform tl
784
      in
785
      let ok, random_mutation = apply_transform transforms in
786
      let stop_process () =
787
	report ~level:1 (fun fmt -> fprintf fmt
788
	  "Only %i mutants directives generated out of %i expected@ "
789
	  (nb-rnb)
790
	  nb); 
791
	mutants
792
      in
793
      if not ok then
794
	stop_process ()
795
      else if List.mem random_mutation mutants then
796
	try
797
	  let new_mutant = (find_next_new mutants random_mutation) in
798
	  report ~level:2 (fun fmt -> fprintf fmt " %i mutants directive generated out of %i expected@ " (nb-rnb) nb);
799
	  create_mutants_directives (rnb-1) (new_mutant::mutants) 
800
	with Not_found -> (
801
	  stop_process ()
802
	)
803
      else (
804
	create_mutants_directives (rnb-1) (random_mutation::mutants)
805
      )
806
  in
807
  let mutants_directives = create_mutants_directives nb [] in
808
  List.map (fun d ->
809
    let mutant, loc = create_mutant prog d in
810
    d, loc, mutant ) mutants_directives 
811
  
812

    
813
let mutate nb prog =
814
  records := compute_records prog;
815
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
816
  (*   !records.nb_pre *)
817
(*     !records.nb_boolexpr *)
818
(*     (\* !records.op *\) *)
819
(* ;  *)   
820
  fold_mutate nb prog 
821

    
822

    
823

    
824

    
825
(* Local Variables: *)
826
(* compile-command:"make -C .." *)
827
(* End: *)
828

    
829