Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ df94cd73

History | View | Annotate | Download (26.9 KB)

1

    
2
(* Comments in function fold_mutate
3

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

    
10
*)
11

    
12

    
13
open Lustre_types
14
open Corelang
15
open Log
16
open Format
17

    
18
let random_seed = ref 0
19
let threshold_delay = 95
20
let threshold_inc_int = 97
21
let threshold_dec_int = 97
22
let threshold_random_int = 96
23
let threshold_switch_int = 100 (* not implemented yet *)
24
let threshold_random_float = 100 (* not used yet *)
25
let threshold_negate_bool_var = 95
26
let threshold_arith_op = 95
27
let threshold_rel_op = 95
28
let threshold_bool_op = 95
29

    
30
let int_consts = ref []
31

    
32
let rename_app id =
33
  if List.mem id Basic_library.internal_funs ||
34
       !Options.no_mutation_suffix then
35
    id
36
  else
37
    let node = Corelang.node_from_name id in
38
    let is_imported =
39
      match node.top_decl_desc with
40
      | ImportedNode _ -> true
41
      | _ -> false
42
    in
43
    if is_imported then
44
      id
45
    else
46
      id ^ "_mutant"
47

    
48
(************************************************************************************)
49
(*                    Gathering constants in the code                               *)
50
(************************************************************************************)
51

    
52
module IntSet = Set.Make (struct type t = int let compare = compare end)
53
module OpCount = Mmap.Make (struct type t = string let compare = compare end)
54

    
55
type records = {
56
  consts: IntSet.t;
57
  nb_consts: int;
58
  nb_boolexpr: int;
59
  nb_pre: int;
60
  nb_op: int OpCount.t;
61
}
62

    
63
let arith_op = ["+" ; "-" ; "*" ; "/"] 
64
let bool_op = ["&&"; "||"; "xor";  "impl"] 
65
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
66
let ops = arith_op @ bool_op @ rel_op
67
let all_ops = "not" :: ops
68

    
69
let empty_records = 
70
  {consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
71

    
72
let records = ref empty_records
73

    
74
let merge_records records_list = 
75
  let merge_record r1 r2 =
76
    {
77
      consts = IntSet.union r1.consts r2.consts;
78

    
79
      nb_consts = r1.nb_consts + r2.nb_consts;
80
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
81
      nb_pre = r1.nb_pre + r2.nb_pre;
82

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

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

    
128
let compute_records_eq eq = compute_records_expr eq.eq_rhs
129

    
130
let compute_records_node nd =
131
  let eqs, auts = get_node_eqs nd in
132
  assert (auts=[]); (* Automaton should be expanded by now *)
133
  merge_records (List.map compute_records_eq eqs)
134

    
135
let compute_records_top_decl td =
136
  match td.top_decl_desc with
137
  | Node nd -> compute_records_node nd
138
  | Const cst -> compute_records_const_value cst.const_value
139
  | _ -> empty_records
140

    
141
let compute_records prog = 
142
  merge_records (List.map compute_records_top_decl prog)
143

    
144
(*****************************************************************)
145
(*                  Random mutation                              *)
146
(*****************************************************************)
147

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

    
165
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
166

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

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

    
208

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

    
223

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

    
234
let rdm_mutate_const c =
235
  let new_const = rdm_mutate_const_value c.const_value in
236
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
237
  mut, { c with const_value = new_const }
238

    
239

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

    
254

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

    
309
let rdm_mutate_eq eq =
310
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
311
  mutation, { eq with eq_rhs = new_rhs }
312

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

    
323
let rdm_mutate_node nd = 
324
  let mutation, new_node_stmts =       
325
    select_in_list 
326
      nd.node_stmts rnd_mutate_stmt
327
  in
328
  mutation, { nd with node_stmts = new_node_stmts }
329

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

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

    
367

    
368
(*****************************************************************)
369
(*                  Random mutation                              *)
370
(*****************************************************************)
371

    
372
type mutant_t =
373
  | Boolexpr of int
374
  | Pre of int
375
  | Op of string * int * string
376
  | IncrIntCst of int
377
  | DecrIntCst of int
378
  | SwitchIntCst of int * int 
379

    
380
(* Denotes the parent node, the equation lhs and the location of the mutation *)
381
type mutation_loc = ident * ident list * Location.t
382
let target : mutant_t option ref = ref None
383

    
384
let mutation_info : mutation_loc option ref = ref None
385
let current_node: ident option ref = ref None 
386
let current_eq_lhs : ident list option ref = ref None
387
let current_loc : Location.t option ref = ref None
388
  
389
let set_mutation_loc () =
390
  target := None;
391
  match !current_node, !current_eq_lhs, !current_loc with
392
  | Some n, Some elhs, Some l ->  mutation_info := Some (n, elhs, l)
393
  | _ -> assert false (* Those global vars should be defined during the
394
			   visitor pattern execution *)
395

    
396
let print_directive fmt d =
397
  match d with
398
  | Pre n -> Format.fprintf fmt "pre %i" n
399
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
400
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
401
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
402
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
403
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
404

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

    
441
let fold_mutate_op op = 
442
(* match op with *)
443
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
444
(*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
445
(*   List.nth filtered (Random.int 3) *)
446
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
447
(*   let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
448
(*   List.nth filtered (Random.int 3) *)
449
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
450
(*   let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
451
(*   List.nth filtered (Random.int 5) *)
452
(* | _ -> op *)
453
  match !target with
454
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
455
    set_mutation_loc ();
456
    op_new
457
  )
458
  | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
459
    target := Some (Op(op_orig, n-1, op_new));
460
    op
461
  )
462
  | _ -> op
463

    
464

    
465
let fold_mutate_var expr = 
466
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
467
  (* | Types.Tbool -> *)
468
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
469
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
470
  (*   (\* else  *\) *)
471
  (*   (\*   expr *\) *)
472
  (* | _ -> 
473
 *)expr
474

    
475
let fold_mutate_boolexpr expr =
476
  match !target with
477
  | Some (Boolexpr 0) -> (
478
     set_mutation_loc ();
479

    
480
    mkpredef_call expr.expr_loc "not" [expr]
481
  )
482
  | Some (Boolexpr n) ->
483
      (target := Some (Boolexpr (n-1)); expr)
484
  | _ -> expr
485
    
486
let fold_mutate_pre orig_expr e = 
487
  match !target with
488
    Some (Pre 0) -> (
489
      set_mutation_loc ();
490
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
491
    )
492
  | Some (Pre n) -> (
493
    target := Some (Pre (n-1));
494
    Expr_pre e
495
  )
496
  | _ -> Expr_pre e
497
    
498
let fold_mutate_const_value c =
499
  match c with
500
  | Const_int i -> (
501
    match !target with
502
    | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
503
    | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
504
    | Some (SwitchIntCst (0, id)) ->
505
       (set_mutation_loc (); Const_int id) 
506
    | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
507
    | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
508
    | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
509
    | _ -> c)
510
  | _ -> c
511

    
512
(*
513
  match c with
514
  | Const_int i -> Const_int (fold_mutate_int i)
515
  | Const_real s -> Const_real s (* those are string, let's leave them *)
516
  | Const_float f -> Const_float (fold_mutate_float f)
517
  | Const_array _
518
  | Const_tag _ -> c
519
TODO
520

    
521
				  *)
522
let fold_mutate_const c =
523
  { c with const_value = fold_mutate_const_value c.const_value }
524

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

    
559
let fold_mutate_eq eq =
560
  current_eq_lhs := Some eq.eq_lhs;
561
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
562

    
563
let fold_mutate_stmt stmt =
564
  match stmt with
565
  | Eq eq   -> Eq (fold_mutate_eq eq)
566
  | Aut aut -> assert false
567

    
568

    
569
let fold_mutate_node nd =
570
  current_node := Some nd.node_id;
571
  let nd =
572
    { nd with 
573
      node_stmts = 
574
        List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
575
    }
576
  in
577
  rename_node rename_app (fun x -> x) nd 
578

    
579
let fold_mutate_top_decl td =
580
  match td.top_decl_desc with
581
  | Node nd   -> { td with top_decl_desc = Node  (fold_mutate_node nd)}
582
  | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
583
  | _ -> td
584
    
585
(* Create a single mutant with the provided random seed *)
586
let fold_mutate_prog prog = 
587
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
588

    
589
let create_mutant prog directive =  
590
  target := Some directive; 
591
  let prog' = fold_mutate_prog prog in
592
  let mutation_info = match !target , !mutation_info with
593
    | None, Some mi -> mi
594
    | _ -> (
595
      Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive;
596
      let _ = match !target with Some dir' -> Format.eprintf "New directive %a@.@?" print_directive dir' | _ -> () in
597
      assert false (* The mutation has not been performed. *)
598
    )
599
     
600
  in
601
(*  target := None; (* should happen only if no mutation occured during the
602
    visit *)*)
603
  prog', mutation_info
604
  
605

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

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

    
681
  in
682
   (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res;  *)
683
  res
684

    
685
let fold_mutate nb prog = 
686
  incr random_seed;
687
  Random.init !random_seed;
688
  (* Local references to keep track of generated directives *)
689

    
690
  (* build a set of integer 0, 1, ... n-1 for input n *)
691
  let cpt_to_intset cpt =
692
    let arr = Array.init cpt (fun x -> x) in
693
    Array.fold_right IntSet.add arr IntSet.empty
694
  in
695
  
696
  let possible_const_id = cpt_to_intset !records.nb_consts in
697
  (* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)
698
  (* let possible_pre_id = cpt_to_intset !records.nb_pre in *)
699
  
700
  let incremented_const_id = ref IntSet.empty in
701
  let decremented_const_id = ref IntSet.empty in
702
  
703
  let create_new_incr_decr registered build =
704
    let possible = IntSet.diff possible_const_id !registered |> IntSet.elements in
705
    let len = List.length possible in
706
    if len <= 0 then
707
      false, build (-1) (* Should not be stored *)
708
    else
709
      let picked = List.nth possible (Random.int (List.length possible)) in
710
      registered := IntSet.add picked !registered;
711
      true, build picked
712
  in
713

    
714

    
715
  let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in
716
  let switch_const_id = ref DblIntSet.empty in
717
  let switch_set =
718
    if IntSet.cardinal !records.consts <= 1 then
719
      DblIntSet.empty
720
    else
721
      (* First element is cst id (the ith cst) while second is the
722
		       ith element of the set of gathered constants
723
		       !record.consts *)
724
      IntSet.fold (fun cst_id set ->
725
	  IntSet.fold (fun ith_cst set ->
726
	      DblIntSet.add (cst_id, ith_cst) set
727
	    ) !records.consts set
728
        ) possible_const_id DblIntSet.empty 
729
  in
730

    
731
  let create_new_switch registered build =
732
    let possible = DblIntSet.diff switch_set !registered |> DblIntSet.elements in
733
    let len = List.length possible in
734
    if len <= 0 then
735
      false, build (-1,-1) (* Should not be stored *)
736
    else
737
      let picked = List.nth possible (Random.int (List.length possible)) in
738
      registered := DblIntSet.add picked !registered;
739
      true, build picked
740
  in
741
  
742
  let find_next_new mutants mutant =
743
    let rec find_next_new init current =
744
      if init = current || List.mem current mutants then raise Not_found else
745

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

    
833
let mutate nb prog =
834
  records := compute_records prog;
835
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
836
  (*   !records.nb_pre *)
837
(*     !records.nb_boolexpr *)
838
(*     (\* !records.op *\) *)
839
(* ;  *)   
840
  fold_mutate nb prog 
841

    
842

    
843

    
844

    
845
(* Local Variables: *)
846
(* compile-command:"make -C .." *)
847
(* End: *)
848

    
849