Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ 5487dd79

History | View | Annotate | Download (24.6 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 LustreSpec
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 !Options.no_mutation_suffix then
34
    id
35
  else
36
    id ^ "_mutant"
37

    
38
(************************************************************************************)
39
(*                    Gathering constants in the code                               *)
40
(************************************************************************************)
41

    
42
module IntSet = Set.Make (struct type t = int let compare = compare end)
43
module OpCount = Mmap.Make (struct type t = string let compare = compare end)
44

    
45
type records = {
46
  consts: IntSet.t;
47
  nb_boolexpr: int;
48
  nb_pre: int;
49
  nb_op: int OpCount.t;
50
}
51

    
52
let arith_op = ["+" ; "-" ; "*" ; "/"] 
53
let bool_op = ["&&"; "||"; "xor";  "impl"] 
54
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
55
let ops = arith_op @ bool_op @ rel_op
56
let all_ops = "not" :: ops
57

    
58
let empty_records = 
59
  {consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
60

    
61
let records = ref empty_records
62

    
63
let merge_records records_list = 
64
  let merge_record r1 r2 =
65
    {
66
      consts = IntSet.union r1.consts r2.consts;
67

    
68
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
69
      nb_pre = r1.nb_pre + r2.nb_pre;
70

    
71
      nb_op = OpCount.merge (fun op r1opt r2opt ->
72
	match r1opt, r2opt with
73
	| None, _ -> r2opt
74
	| _, None -> r1opt
75
	| Some x, Some y -> Some (x+y)
76
      ) r1.nb_op r2.nb_op 
77
    }
78
  in
79
  List.fold_left merge_record empty_records records_list
80
  
81
let compute_records_const_value c =
82
  match c with
83
  | Const_int i -> {empty_records with consts = IntSet.singleton i}
84
  | _ -> empty_records
85

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

    
116
let compute_records_eq eq = compute_records_expr eq.eq_rhs
117

    
118
let compute_records_node nd =
119
  let eqs, auts = get_node_eqs nd in
120
  assert (auts=[]); (* Automaton should be expanded by now *)
121
  merge_records (List.map compute_records_eq eqs)
122

    
123
let compute_records_top_decl td =
124
  match td.top_decl_desc with
125
  | Node nd -> compute_records_node nd
126
  | Const cst -> compute_records_const_value cst.const_value
127
  | _ -> empty_records
128

    
129
let compute_records prog = 
130
  merge_records (List.map compute_records_top_decl prog)
131

    
132
(*****************************************************************)
133
(*                  Random mutation                              *)
134
(*****************************************************************)
135

    
136
let check_mut e1 e2 =
137
  let rec eq e1 e2 =
138
    match e1.expr_desc, e2.expr_desc with
139
    | Expr_const c1, Expr_const c2 -> c1 = c2
140
    | Expr_ident id1, Expr_ident id2 -> id1 = id2
141
    | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2
142
    | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2
143
    | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2
144
    | Expr_pre e1, Expr_pre e2 -> eq e1 e2
145
    | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2
146
  | _ -> false
147
  in
148
  if not (eq e1 e2) then
149
    Some (e1, e2)
150
  else
151
    None
152

    
153
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
154

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

    
183
let rdm_mutate_op op = 
184
match op with
185
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
186
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
187
  List.nth filtered (Random.int 3)
188
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
189
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
190
  List.nth filtered (Random.int 3)
191
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
192
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
193
  List.nth filtered (Random.int 5)
194
| _ -> op
195

    
196

    
197
let rdm_mutate_var expr = 
198
  match (Types.repr expr.expr_type).Types.tdesc with 
199
  | Types.Tbool ->
200
    (* if Random.int 100 > threshold_negate_bool_var then *)
201
    let new_e = mkpredef_call expr.expr_loc "not" [expr] in
202
    Some (expr, new_e), new_e
203
    (* else  *)
204
    (*   expr *)
205
  | _ -> None, expr
206
    
207
let rdm_mutate_pre orig_expr = 
208
  let new_e = Expr_pre orig_expr in
209
  Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e
210

    
211

    
212
let rdm_mutate_const_value c =
213
  match c with
214
  | Const_int i -> Const_int (rdm_mutate_int i)
215
  | Const_real (n, i, s) -> let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s')
216
  | Const_array _
217
  | Const_string _
218
  | Const_struct _
219
  | Const_tag _ -> c
220

    
221
let rdm_mutate_const c =
222
  let new_const = rdm_mutate_const_value c.const_value in
223
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
224
  mut, { c with const_value = new_const }
225

    
226

    
227
let select_in_list list rdm_mutate_elem = 
228
  let selected = Random.int (List.length list) in
229
  let mutation_opt, new_list, _ = 
230
    List.fold_right
231
      (fun elem (mutation_opt, res, cpt) -> if cpt = selected then 
232
	  let mutation, new_elem = rdm_mutate_elem elem in
233
	  Some mutation, new_elem::res, cpt+1  else mutation_opt, elem::res, cpt+1)
234
      list 
235
      (None, [], 0)
236
  in
237
  match mutation_opt with
238
  | Some mut -> mut, new_list
239
  | _ -> assert false
240

    
241

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

    
296
let rdm_mutate_eq eq =
297
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
298
  mutation, { eq with eq_rhs = new_rhs }
299

    
300
let rnd_mutate_stmt stmt =
301
  match stmt with
302
  | Eq eq   -> let mut, new_eq = rdm_mutate_eq eq in
303
		 report ~level:1 
304
		   (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
305
		     Printers.pp_node_eq eq
306
		     Printers.pp_node_eq new_eq);
307
		 mut, Eq new_eq 
308
  | Aut aut -> assert false
309

    
310
let rdm_mutate_node nd = 
311
  let mutation, new_node_stmts =       
312
    select_in_list 
313
      nd.node_stmts rnd_mutate_stmt
314
  in
315
  mutation, { nd with node_stmts = new_node_stmts }
316

    
317
let rdm_mutate_top_decl td =
318
  match td.top_decl_desc with
319
  | Node nd -> 
320
    let mutation, new_node = rdm_mutate_node nd in 
321
    mutation, { td with top_decl_desc = Node new_node}
322
  | Const cst -> 
323
    let mut, new_cst = rdm_mutate_const cst in
324
    mut, { td with top_decl_desc = Const new_cst }
325
  | _ -> None, td
326
    
327
(* Create a single mutant with the provided random seed *)
328
let rdm_mutate_prog prog = 
329
  select_in_list prog rdm_mutate_top_decl
330

    
331
let rdm_mutate nb prog = 
332
  let rec iterate nb res =
333
    incr random_seed;
334
    if nb <= 0 then
335
      res
336
    else (
337
      Random.init !random_seed;
338
      let mutation, new_mutant = rdm_mutate_prog prog in
339
      match mutation with
340
	None -> iterate nb res 
341
      | Some mutation -> ( 
342
	if List.mem_assoc mutation res then (
343
	  iterate nb res
344
	)
345
	else (
346
	  report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb); 
347
	  iterate (nb-1) ((mutation, new_mutant)::res)
348
	)
349
      )
350
    )
351
  in
352
  iterate nb []
353

    
354

    
355
(*****************************************************************)
356
(*                  Random mutation                              *)
357
(*****************************************************************)
358

    
359
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int 
360

    
361
(* Denotes the parent node, the equation lhs and the location of the mutation *)
362
type mutation_loc = ident * ident list * Location.t
363
let target : mutant_t option ref = ref None
364

    
365
let mutation_info : mutation_loc option ref = ref None
366
let current_node: ident option ref = ref None 
367
let current_eq_lhs : ident list option ref = ref None
368
let current_loc : Location.t option ref = ref None
369
  
370
let set_mutation_loc () =
371
  target := None;
372
  match !current_node, !current_eq_lhs, !current_loc with
373
  | Some n, Some elhs, Some l ->  mutation_info := Some (n, elhs, l)
374
  | _ -> assert false (* Those global vars should be defined during the
375
			   visitor pattern execution *)
376

    
377
let print_directive fmt d =
378
  match d with
379
  | Pre n -> Format.fprintf fmt "pre %i" n
380
  | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
381
  | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
382
  | IncrIntCst n ->  Format.fprintf fmt "incr int cst %i" n
383
  | DecrIntCst n ->  Format.fprintf fmt "decr int cst %i" n
384
  | SwitchIntCst (n, m) ->  Format.fprintf fmt "switch int cst %i -> %i" n m
385

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

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

    
445

    
446
let fold_mutate_var expr = 
447
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
448
  (* | Types.Tbool -> *)
449
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
450
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
451
  (*   (\* else  *\) *)
452
  (*   (\*   expr *\) *)
453
  (* | _ -> 
454
 *)expr
455

    
456
let fold_mutate_boolexpr expr =
457
  match !target with
458
  | Some (Boolexpr 0) -> (
459
     set_mutation_loc ();
460

    
461
    mkpredef_call expr.expr_loc "not" [expr]
462
  )
463
  | Some (Boolexpr n) ->
464
      (target := Some (Boolexpr (n-1)); expr)
465
  | _ -> expr
466
    
467
let fold_mutate_pre orig_expr e = 
468
  match !target with
469
    Some (Pre 0) -> (
470
      set_mutation_loc ();
471
      Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
472
    )
473
  | Some (Pre n) -> (
474
    target := Some (Pre (n-1));
475
    Expr_pre e
476
  )
477
  | _ -> Expr_pre e
478
    
479
let fold_mutate_const_value c = 
480
match c with
481
| Const_int i -> (
482
  match !target with
483
  | Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
484
  | Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
485
  | Some (SwitchIntCst (0, id)) -> (set_mutation_loc (); Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id)) 
486
  | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
487
  | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
488
  | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
489
  | _ -> c)
490
| _ -> c
491

    
492
(*
493
  match c with
494
  | Const_int i -> Const_int (fold_mutate_int i)
495
  | Const_real s -> Const_real s (* those are string, let's leave them *)
496
  | Const_float f -> Const_float (fold_mutate_float f)
497
  | Const_array _
498
  | Const_tag _ -> c
499
TODO
500

    
501
				  *)
502
let fold_mutate_const c =
503
  { c with const_value = fold_mutate_const_value c.const_value }
504

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

    
539
let fold_mutate_eq eq =
540
  current_eq_lhs := Some eq.eq_lhs;
541
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
542

    
543
let fold_mutate_stmt stmt =
544
  match stmt with
545
  | Eq eq   -> Eq (fold_mutate_eq eq)
546
  | Aut aut -> assert false
547

    
548
let fold_mutate_node nd =
549
  current_node := Some nd.node_id;
550
  { nd with 
551
    node_stmts = 
552
      List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
553
    node_id = rename_app nd.node_id
554
  }
555

    
556
let fold_mutate_top_decl td =
557
  match td.top_decl_desc with
558
  | Node nd   -> { td with top_decl_desc = Node  (fold_mutate_node nd)}
559
  | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
560
  | _ -> td
561
    
562
(* Create a single mutant with the provided random seed *)
563
let fold_mutate_prog prog = 
564
  List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
565

    
566
let create_mutant prog directive =  
567
  target := Some directive; 
568
  let prog' = fold_mutate_prog prog in
569
  let mutation_info = match !target , !mutation_info with
570
    | None, Some mi -> mi
571
    | _ -> (
572
      Format.eprintf "Failed when creating mutant for directive %a@.@?" print_directive directive;
573
      let _ = match !target with Some dir' -> Format.eprintf "New directive %a@.@?" print_directive dir' | _ -> () in
574
      assert false (* The mutation has not been performed. *)
575
    )
576
     
577
  in
578
(*  target := None; (* should happen only if no mutation occured during the
579
    visit *)*)
580
  prog', mutation_info
581
  
582

    
583
let op_mutation op = 
584
  let res =
585
    let rem_op l = List.filter (fun e -> e <> op) l in
586
  if List.mem op arith_op then rem_op arith_op else 
587
    if List.mem op bool_op then rem_op bool_op else 
588
      if List.mem op rel_op then rem_op rel_op else 
589
	(Format.eprintf "Failing with op %s@." op;
590
	  assert false
591
	)
592
  in
593
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
594
  res
595

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

    
658
  in
659
   (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res;  *)
660
  res
661

    
662
let fold_mutate nb prog = 
663
  incr random_seed;
664
  Random.init !random_seed;
665
  let find_next_new mutants mutant =
666
    let rec find_next_new init current =
667
      if init = current || List.mem current mutants then raise Not_found else
668

    
669
	  (* TODO: check if we can generate more cases. The following lines were
670
	     cylcing and missing to detect that the enumaration was complete,
671
	     leading to a non terminating process. The current setting is harder
672
	     but may miss enumerating some cases. To be checked! *)
673
	
674
	  (* if List.mem current mutants then *)
675
	  (*   find_next_new init (next_change current) *)
676
	  (* else *)
677
	current
678
    in
679
    find_next_new mutant (next_change mutant) 
680
  in
681
  (* Creating list of nb elements of mutants *)
682
  let rec create_mutants_directives rnb mutants = 
683
    if rnb <= 0 then mutants 
684
    else
685
      (* Initial list of transformation *)
686
      let rec init_list x = if x <= 0 then [0] else x::(init_list (x-1)) in
687
      let init_list = init_list 5 in
688
      (* We generate a random permutation of the list: the first item is the
689
	 transformation, the rest of the list act as fallback choices to make
690
	 sure we produce something *)
691
      let shuffle l =
692
	let nd = List.map (fun c -> Random.bits (), c) l in
693
	let sond = List.sort compare nd in
694
	List.map snd sond
695
      in
696
      let transforms = shuffle init_list in
697
      let rec apply_transform transforms =
698
	let f id = 
699
	  match id with
700
	  | 5 -> let card = IntSet.cardinal !records.consts in
701
		 card > 0, IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
702
	  | 4 -> let card = IntSet.cardinal !records.consts in
703
		 card > 0, DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
704
	  | 3 -> let card = IntSet.cardinal !records.consts in
705
		 card > 0, SwitchIntCst ((try Random.int (-1  + IntSet.cardinal !records.consts) with _ -> 0), (try Random.int (-1 + IntSet.cardinal !records.consts) with _ -> 0))
706
	  | 2 -> !records.nb_pre >0, Pre (try Random.int !records.nb_pre with _ -> 0)
707
	  | 1 -> !records.nb_boolexpr > 0, Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
708
	  | 0 -> let bindings = OpCount.bindings !records.nb_op in
709
		 let bindings_len = List.length bindings in
710
		 let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ -> 0) in
711
		 let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ -> 0) in
712
	         bindings_len > 0, Op (op, (try Random.int nb_op with _ -> 0), new_op)
713
	  | _ -> assert false
714
	in
715
	match transforms with
716
	| [] -> assert false
717
	| [hd] -> f hd
718
	| hd::tl -> let ok, random_mutation = f hd in
719
		    if ok then
720
		      ok, random_mutation
721
		    else
722
		      apply_transform tl
723
      in
724
      let ok, random_mutation = apply_transform transforms in
725
      let stop_process () =
726
	report ~level:1 (fun fmt -> fprintf fmt
727
	  "Only %i mutants directives generated out of %i expected@."
728
	  (nb-rnb)
729
	  nb); 
730
	mutants
731
      in
732
      if not ok then
733
	stop_process ()
734
      else if List.mem random_mutation mutants then
735
	try
736
	  let new_mutant = (find_next_new mutants random_mutation) in
737
	  report ~level:2 (fun fmt -> fprintf fmt " %i mutants directive generated out of %i expected@." (nb-rnb) nb);
738
	  create_mutants_directives (rnb-1) (new_mutant::mutants) 
739
	with Not_found -> (
740
	  stop_process ()
741
	)
742
      else (
743
	create_mutants_directives (rnb-1) (random_mutation::mutants)
744
      )
745
  in
746
  let mutants_directives = create_mutants_directives nb [] in
747
  List.map (fun d ->
748
    let mutant, loc = create_mutant prog d in
749
    d, loc, mutant ) mutants_directives 
750
  
751

    
752
let mutate nb prog =
753
  records := compute_records prog;
754
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
755
  (*   !records.nb_pre *)
756
(*     !records.nb_boolexpr *)
757
(*     (\* !records.op *\) *)
758
(* ;  *)   
759
  fold_mutate nb prog 
760

    
761

    
762

    
763

    
764
(* Local Variables: *)
765
(* compile-command:"make -C .." *)
766
(* End: *)
767

    
768