Project

General

Profile

Download (27.8 KB) Statistics
| Branch: | Tag: | Revision:
1
(* Comments in function fold_mutate
2

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

    
8
open Lustre_types
9
open Corelang
10
open Log
11
open Format
12

    
13
let random_seed = ref 0
14

    
15
let threshold_delay = 95
16

    
17
let threshold_inc_int = 97
18

    
19
let threshold_dec_int = 97
20

    
21
let threshold_random_int = 96
22

    
23
let threshold_switch_int = 100
24
(* not implemented yet *)
25

    
26
let threshold_random_float = 100
27
(* not used yet *)
28

    
29
let threshold_negate_bool_var = 95
30

    
31
let threshold_arith_op = 95
32

    
33
let threshold_rel_op = 95
34

    
35
let threshold_bool_op = 95
36

    
37
let int_consts = ref []
38

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

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

    
53
module IntSet = Set.Make (struct
54
  type t = int
55

    
56
  let compare = compare
57
end)
58

    
59
module OpCount = Mmap.Make (struct
60
  type t = string
61

    
62
  let compare = compare
63
end)
64

    
65
type records = {
66
  consts : IntSet.t;
67
  nb_consts : int;
68
  nb_boolexpr : int;
69
  nb_pre : int;
70
  nb_op : int OpCount.t;
71
}
72

    
73
let arith_op = [ "+"; "-"; "*"; "/" ]
74

    
75
let bool_op = [ "&&"; "||"; "xor"; "impl" ]
76

    
77
let rel_op = [ "<"; "<="; ">"; ">="; "!="; "=" ]
78

    
79
let ops = arith_op @ bool_op @ rel_op
80

    
81
let all_ops = "not" :: ops
82

    
83
let empty_records =
84
  {
85
    consts = IntSet.empty;
86
    nb_consts = 0;
87
    nb_boolexpr = 0;
88
    nb_pre = 0;
89
    nb_op = OpCount.empty;
90
  }
91

    
92
let records = ref empty_records
93

    
94
let merge_records records_list =
95
  let merge_record r1 r2 =
96
    {
97
      consts = IntSet.union r1.consts r2.consts;
98
      nb_consts = r1.nb_consts + r2.nb_consts;
99
      nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
100
      nb_pre = r1.nb_pre + r2.nb_pre;
101
      nb_op =
102
        OpCount.merge
103
          (fun _ r1opt r2opt ->
104
            match r1opt, r2opt with
105
            | None, _ ->
106
              r2opt
107
            | _, None ->
108
              r1opt
109
            | Some x, Some y ->
110
              Some (x + y))
111
          r1.nb_op r2.nb_op;
112
    }
113
  in
114
  List.fold_left merge_record empty_records records_list
115

    
116
let compute_records_const_value c =
117
  match c with
118
  | Const_int i ->
119
    { empty_records with consts = IntSet.singleton i; nb_consts = 1 }
120
  | _ ->
121
    empty_records
122

    
123
let rec compute_records_expr expr =
124
  let boolexpr =
125
    if Types.is_bool_type expr.expr_type then
126
      { empty_records with nb_boolexpr = 1 }
127
    else empty_records
128
  in
129
  let subrec =
130
    match expr.expr_desc with
131
    | Expr_const c ->
132
      compute_records_const_value c
133
    | Expr_tuple l ->
134
      merge_records (List.map compute_records_expr l)
135
    | Expr_ite (i, t, e) ->
136
      merge_records (List.map compute_records_expr [ i; t; e ])
137
    | Expr_arrow (e1, e2) ->
138
      merge_records (List.map compute_records_expr [ e1; e2 ])
139
    | Expr_pre e ->
140
      merge_records
141
        [ { empty_records with nb_pre = 1 }; compute_records_expr e ]
142
    | Expr_appl (op_id, args, _) ->
143
      if List.mem op_id ops then
144
        merge_records
145
          [
146
            { empty_records with nb_op = OpCount.singleton op_id 1 };
147
            compute_records_expr args;
148
          ]
149
      else compute_records_expr args
150
    | _ ->
151
      empty_records
152
  in
153
  merge_records [ boolexpr; subrec ]
154

    
155
let compute_records_eq eq = compute_records_expr eq.eq_rhs
156

    
157
let compute_records_node nd =
158
  let eqs, auts = get_node_eqs nd in
159
  assert (auts = []);
160
  (* Automaton should be expanded by now *)
161
  merge_records (List.map compute_records_eq eqs)
162

    
163
let compute_records_top_decl td =
164
  match td.top_decl_desc with
165
  | Node nd ->
166
    compute_records_node nd
167
  | Const cst ->
168
    compute_records_const_value cst.const_value
169
  | _ ->
170
    empty_records
171

    
172
let compute_records prog =
173
  merge_records (List.map compute_records_top_decl prog)
174

    
175
(*****************************************************************)
176
(*                  Random mutation                              *)
177
(*****************************************************************)
178

    
179
let check_mut e1 e2 =
180
  let rec eq e1 e2 =
181
    match e1.expr_desc, e2.expr_desc with
182
    | Expr_const c1, Expr_const c2 ->
183
      c1 = c2
184
    | Expr_ident id1, Expr_ident id2 ->
185
      id1 = id2
186
    | Expr_tuple el1, Expr_tuple el2 ->
187
      List.length el1 = List.length el2 && List.for_all2 eq el1 el2
188
    | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
189
      eq i1 i2 && eq t1 t2 && eq e1 e2
190
    | Expr_arrow (x1, y1), Expr_arrow (x2, y2) ->
191
      eq x1 x2 && eq y1 y2
192
    | Expr_pre e1, Expr_pre e2 ->
193
      eq e1 e2
194
    | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) ->
195
      id1 = id2 && eq e1 e2
196
    | _ ->
197
      false
198
  in
199
  if not (eq e1 e2) then Some (e1, e2) else None
200

    
201
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
202

    
203
let rdm_mutate_int i =
204
  if Random.int 100 > threshold_inc_int then i + 1
205
  else if Random.int 100 > threshold_dec_int then i - 1
206
  else if Random.int 100 > threshold_random_int then Random.int 10
207
  else if Random.int 100 > threshold_switch_int then
208
    let idx = Random.int (List.length !int_consts) in
209
    List.nth !int_consts idx
210
  else i
211

    
212
let rdm_mutate_real r =
213
  if Random.int 100 > threshold_random_float then
214
    (* interval [0, bound] for random values *)
215
    let bound = 10 in
216
    (* max number of digits after comma *)
217
    let digits = 5 in
218
    (* number of digits after comma *)
219
    let shift = Random.int (digits + 1) in
220
    let eshift = 10. ** float_of_int shift in
221
    let i = Random.int (1 + (bound * int_of_float eshift)) in
222
    let f = float_of_int i /. eshift in
223
    Real.create (string_of_int i) shift (string_of_float f)
224
  else r
225

    
226
let rdm_mutate_op op =
227
  match op with
228
  | ("+" | "-" | "*" | "/") when Random.int 100 > threshold_arith_op ->
229
    let filtered = List.filter (fun x -> x <> op) [ "+"; "-"; "*"; "/" ] in
230
    List.nth filtered (Random.int 3)
231
  | ("&&" | "||" | "xor" | "impl") when Random.int 100 > threshold_bool_op ->
232
    let filtered =
233
      List.filter (fun x -> x <> op) [ "&&"; "||"; "xor"; "impl" ]
234
    in
235
    List.nth filtered (Random.int 3)
236
  | ("<" | "<=" | ">" | ">=" | "!=" | "=")
237
    when Random.int 100 > threshold_rel_op ->
238
    let filtered =
239
      List.filter (fun x -> x <> op) [ "<"; "<="; ">"; ">="; "!="; "=" ]
240
    in
241
    List.nth filtered (Random.int 5)
242
  | _ ->
243
    op
244

    
245
let rdm_mutate_var expr =
246
  if Types.is_bool_type expr.expr_type then
247
    (* if Random.int 100 > threshold_negate_bool_var then *)
248
    let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
249
    Some (expr, new_e), new_e
250
    (* else  *)
251
    (*   expr *)
252
  else None, expr
253

    
254
let rdm_mutate_pre orig_expr =
255
  let new_e = Expr_pre orig_expr in
256
  Some (orig_expr, { orig_expr with expr_desc = new_e }), new_e
257

    
258
let rdm_mutate_const_value c =
259
  match c with
260
  | Const_int i ->
261
    Const_int (rdm_mutate_int i)
262
  | Const_real r ->
263
    Const_real (rdm_mutate_real r)
264
  | Const_array _
265
  | Const_string _
266
  | Const_modeid _
267
  | Const_struct _
268
  | Const_tag _ ->
269
    c
270

    
271
let rdm_mutate_const c =
272
  let new_const = rdm_mutate_const_value c.const_value in
273
  let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
274
  mut, { c with const_value = new_const }
275

    
276
let select_in_list list rdm_mutate_elem =
277
  let selected = Random.int (List.length list) in
278
  let mutation_opt, new_list, _ =
279
    List.fold_right
280
      (fun elem (mutation_opt, res, cpt) ->
281
        if cpt = selected then
282
          let mutation, new_elem = rdm_mutate_elem elem in
283
          Some mutation, new_elem :: res, cpt + 1
284
        else mutation_opt, elem :: res, cpt + 1)
285
      list (None, [], 0)
286
  in
287
  match mutation_opt with Some mut -> mut, new_list | _ -> assert false
288

    
289
let rec rdm_mutate_expr expr =
290
  let mk_e d = { expr with expr_desc = d } in
291
  match expr.expr_desc with
292
  | Expr_ident _ ->
293
    rdm_mutate_var expr
294
  | Expr_const c ->
295
    let new_const = rdm_mutate_const_value c in
296
    let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
297
    mut, mk_e (Expr_const new_const)
298
  | Expr_tuple l ->
299
    let mut, l' = select_in_list l rdm_mutate_expr in
300
    mut, mk_e (Expr_tuple l')
301
  | Expr_ite (i, t, e) -> (
302
    let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
303
    match l with
304
    | [ i'; t'; e' ] ->
305
      mut, mk_e (Expr_ite (i', t', e'))
306
    | _ ->
307
      assert false)
308
  | Expr_arrow (e1, e2) -> (
309
    let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
310
    match l with
311
    | [ e1'; e2' ] ->
312
      mut, mk_e (Expr_arrow (e1', e2'))
313
    | _ ->
314
      assert false)
315
  | Expr_pre e ->
316
    let select_pre = Random.bool () in
317
    if select_pre then
318
      let mut, new_expr = rdm_mutate_pre expr in
319
      mut, mk_e new_expr
320
    else
321
      let mut, e' = rdm_mutate_expr e in
322
      mut, mk_e (Expr_pre e')
323
  | Expr_appl (op_id, args, r) ->
324
    let select_op = Random.bool () in
325
    if select_op then
326
      let new_op_id = rdm_mutate_op op_id in
327
      let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
328
      let mut = check_mut expr new_e in
329
      mut, new_e
330
    else
331
      let mut, new_args = rdm_mutate_expr args in
332
      mut, mk_e (Expr_appl (op_id, new_args, r))
333
  (* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of expr
334
     list | Expr_access of expr * Dimension.dim_expr | Expr_power of expr *
335
     Dimension.dim_expr | Expr_when of expr * ident * label | Expr_merge of
336
     ident * (label * expr) list | Expr_uclock of expr * int | Expr_dclock of
337
     expr * int | Expr_phclock of expr * rat *)
338
  | _ ->
339
    None, expr
340

    
341
let rdm_mutate_eq eq =
342
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
343
  mutation, { eq with eq_rhs = new_rhs }
344

    
345
let rnd_mutate_stmt stmt =
346
  match stmt with
347
  | Eq eq ->
348
    let mut, new_eq = rdm_mutate_eq eq in
349
    report ~level:1 (fun fmt ->
350
        fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq
351
          Printers.pp_node_eq new_eq);
352
    mut, Eq new_eq
353
  | Aut _ ->
354
    assert false
355

    
356
let rdm_mutate_node nd =
357
  let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in
358
  mutation, { nd with node_stmts = new_node_stmts }
359

    
360
let rdm_mutate_top_decl td =
361
  match td.top_decl_desc with
362
  | Node nd ->
363
    let mutation, new_node = rdm_mutate_node nd in
364
    mutation, { td with top_decl_desc = Node new_node }
365
  | Const cst ->
366
    let mut, new_cst = rdm_mutate_const cst in
367
    mut, { td with top_decl_desc = Const new_cst }
368
  | _ ->
369
    None, td
370

    
371
(* Create a single mutant with the provided random seed *)
372
let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl
373

    
374
let rdm_mutate nb prog =
375
  let rec iterate nb res =
376
    incr random_seed;
377
    if nb <= 0 then res
378
    else (
379
      Random.init !random_seed;
380
      let mutation, new_mutant = rdm_mutate_prog prog in
381
      match mutation with
382
      | None ->
383
        iterate nb res
384
      | Some mutation ->
385
        if List.mem_assoc mutation res then iterate nb res
386
        else (
387
          report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
388
          iterate (nb - 1) ((mutation, new_mutant) :: res)))
389
  in
390
  iterate nb []
391

    
392
(*****************************************************************)
393
(*                  Random mutation                              *)
394
(*****************************************************************)
395

    
396
type mutant_t =
397
  | Boolexpr of int
398
  | Pre of int
399
  | Op of string * int * string
400
  | IncrIntCst of int
401
  | DecrIntCst of int
402
  | SwitchIntCst of int * int
403

    
404
(* Denotes the parent node, the equation lhs and the location of the mutation *)
405
type mutation_loc = ident * ident list * Location.t
406

    
407
let target : mutant_t option ref = ref None
408

    
409
let mutation_info : mutation_loc option ref = ref None
410

    
411
let current_node : ident option ref = ref None
412

    
413
let current_eq_lhs : ident list option ref = ref None
414

    
415
let current_loc : Location.t option ref = ref None
416

    
417
let set_mutation_loc () =
418
  target := None;
419
  match !current_node, !current_eq_lhs, !current_loc with
420
  | Some n, Some elhs, Some l ->
421
    mutation_info := Some (n, elhs, l)
422
  | _ ->
423
    assert false
424
(* Those global vars should be defined during the visitor pattern execution *)
425

    
426
let print_directive fmt d =
427
  match d with
428
  | Pre n ->
429
    Format.fprintf fmt "pre %i" n
430
  | Boolexpr n ->
431
    Format.fprintf fmt "boolexpr %i" n
432
  | Op (o, i, d) ->
433
    Format.fprintf fmt "%s %i -> %s" o i d
434
  | IncrIntCst n ->
435
    Format.fprintf fmt "incr int cst %i" n
436
  | DecrIntCst n ->
437
    Format.fprintf fmt "decr int cst %i" n
438
  | SwitchIntCst (n, m) ->
439
    Format.fprintf fmt "switch int cst %i -> %i" n m
440

    
441
let print_directive_json fmt d =
442
  match d with
443
  | Pre _ ->
444
    Format.fprintf fmt "\"mutation\": \"pre\""
445
  | Boolexpr _ ->
446
    Format.fprintf fmt "\"mutation\": \"not\""
447
  | Op (o, _, d) ->
448
    Format.fprintf fmt
449
      "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
450
  | IncrIntCst _ ->
451
    Format.fprintf fmt "\"mutation\": \"cst_incr\""
452
  | DecrIntCst _ ->
453
    Format.fprintf fmt "\"mutation\": \"cst_decr\""
454
  | SwitchIntCst (_, m) ->
455
    Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
456

    
457
let print_loc_json fmt (n, eqlhs, l) =
458
  Format.fprintf fmt
459
    "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" n
460
    (Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s))
461
    eqlhs (Location.loc_line l)
462

    
463
let fold_mutate_int i =
464
  if Random.int 100 > threshold_inc_int then i + 1
465
  else if Random.int 100 > threshold_dec_int then i - 1
466
  else if Random.int 100 > threshold_random_int then Random.int 10
467
  else if Random.int 100 > threshold_switch_int then
468
    try
469
      let idx = Random.int (List.length !int_consts) in
470
      List.nth !int_consts idx
471
    with _ -> i
472
  else i
473

    
474
let fold_mutate_float f =
475
  if Random.int 100 > threshold_random_float then Random.float 10. else f
476

    
477
let fold_mutate_op op =
478
  (* match op with *)
479
  (* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
480
  (*   let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
481
  (*   List.nth filtered (Random.int 3) *)
482
  (* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
483
  (* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"]
484
     in *)
485
  (* List.nth filtered (Random.int 3) *)
486
  (* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 >
487
     threshold_rel_op -> *)
488
  (* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!=";
489
     "="] in *)
490
  (*   List.nth filtered (Random.int 5) *)
491
  (* | _ -> op *)
492
  match !target with
493
  | Some (Op (op_orig, 0, op_new)) when op_orig = op ->
494
    set_mutation_loc ();
495
    op_new
496
  | Some (Op (op_orig, n, op_new)) when op_orig = op ->
497
    target := Some (Op (op_orig, n - 1, op_new));
498
    op
499
  | _ ->
500
    op
501

    
502
let fold_mutate_var expr =
503
  (* match (Types.repr expr.expr_type).Types.tdesc with  *)
504
  (* | Types.Tbool -> *)
505
  (*     (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
506
  (*     mkpredef_unary_call Location.dummy_loc "not" expr *)
507
  (*   (\* else  *\) *)
508
  (*   (\*   expr *\) *)
509
  (* | _ ->  *)
510
  expr
511

    
512
let fold_mutate_boolexpr expr =
513
  match !target with
514
  | Some (Boolexpr 0) ->
515
    set_mutation_loc ();
516

    
517
    mkpredef_call expr.expr_loc "not" [ expr ]
518
  | Some (Boolexpr n) ->
519
    target := Some (Boolexpr (n - 1));
520
    expr
521
  | _ ->
522
    expr
523

    
524
let fold_mutate_pre orig_expr e =
525
  match !target with
526
  | Some (Pre 0) ->
527
    set_mutation_loc ();
528
    Expr_pre { orig_expr with expr_desc = Expr_pre e }
529
  | Some (Pre n) ->
530
    target := Some (Pre (n - 1));
531
    Expr_pre e
532
  | _ ->
533
    Expr_pre e
534

    
535
let fold_mutate_const_value c =
536
  match c with
537
  | Const_int i -> (
538
    match !target with
539
    | Some (IncrIntCst 0) ->
540
      set_mutation_loc ();
541
      Const_int (i + 1)
542
    | Some (DecrIntCst 0) ->
543
      set_mutation_loc ();
544
      Const_int (i - 1)
545
    | Some (SwitchIntCst (0, id)) ->
546
      set_mutation_loc ();
547
      Const_int id
548
    | Some (IncrIntCst n) ->
549
      target := Some (IncrIntCst (n - 1));
550
      c
551
    | Some (DecrIntCst n) ->
552
      target := Some (DecrIntCst (n - 1));
553
      c
554
    | Some (SwitchIntCst (n, id)) ->
555
      target := Some (SwitchIntCst (n - 1, id));
556
      c
557
    | _ ->
558
      c)
559
  | _ ->
560
    c
561

    
562
(* match c with | Const_int i -> Const_int (fold_mutate_int i) | Const_real s ->
563
   Const_real s (* those are string, let's leave them *) | Const_float f ->
564
   Const_float (fold_mutate_float f) | Const_array _ | Const_tag _ -> c TODO *)
565
let fold_mutate_const c =
566
  { c with const_value = fold_mutate_const_value c.const_value }
567

    
568
let rec fold_mutate_expr expr =
569
  current_loc := Some expr.expr_loc;
570
  let new_expr =
571
    match expr.expr_desc with
572
    | Expr_ident _ ->
573
      fold_mutate_var expr
574
    | _ ->
575
      let new_desc =
576
        match expr.expr_desc with
577
        | Expr_const c ->
578
          Expr_const (fold_mutate_const_value c)
579
        | Expr_tuple l ->
580
          Expr_tuple
581
            (List.fold_right (fun e res -> fold_mutate_expr e :: res) l [])
582
        | Expr_ite (i, t, e) ->
583
          Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
584
        | Expr_arrow (e1, e2) ->
585
          Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
586
        | Expr_pre e ->
587
          fold_mutate_pre expr (fold_mutate_expr e)
588
        | Expr_appl (op_id, args, r) ->
589
          Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
590
        (* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of
591
           expr list | Expr_access of expr * Dimension.dim_expr | Expr_power of
592
           expr * Dimension.dim_expr | Expr_when of expr * ident * label |
593
           Expr_merge of ident * (label * expr) list | Expr_uclock of expr * int
594
           | Expr_dclock of expr * int | Expr_phclock of expr * rat *)
595
        | _ ->
596
          expr.expr_desc
597
      in
598

    
599
      { expr with expr_desc = new_desc }
600
  in
601
  if Types.is_bool_type expr.expr_type then fold_mutate_boolexpr new_expr
602
  else new_expr
603

    
604
let fold_mutate_eq eq =
605
  current_eq_lhs := Some eq.eq_lhs;
606
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
607

    
608
let fold_mutate_stmt stmt =
609
  match stmt with Eq eq -> Eq (fold_mutate_eq eq) | Aut _ -> assert false
610

    
611
let fold_mutate_node nd =
612
  current_node := Some nd.node_id;
613
  let nd =
614
    {
615
      nd with
616
      node_stmts =
617
        List.fold_right
618
          (fun stmt res -> fold_mutate_stmt stmt :: res)
619
          nd.node_stmts [];
620
    }
621
  in
622
  rename_node rename_app (fun x -> x) nd
623

    
624
let fold_mutate_top_decl td =
625
  match td.top_decl_desc with
626
  | Node nd ->
627
    { td with top_decl_desc = Node (fold_mutate_node nd) }
628
  | Const cst ->
629
    { td with top_decl_desc = Const (fold_mutate_const cst) }
630
  | _ ->
631
    td
632

    
633
(* Create a single mutant with the provided random seed *)
634
let fold_mutate_prog prog =
635
  List.fold_right (fun e res -> fold_mutate_top_decl e :: res) prog []
636

    
637
let create_mutant prog directive =
638
  target := Some directive;
639
  let prog' = fold_mutate_prog prog in
640
  let mutation_info =
641
    match !target, !mutation_info with
642
    | None, Some mi ->
643
      mi
644
    | _ ->
645
      Format.eprintf "Failed when creating mutant for directive %a@.@?"
646
        print_directive directive;
647
      let _ =
648
        match !target with
649
        | Some dir' ->
650
          Format.eprintf "New directive %a@.@?" print_directive dir'
651
        | _ ->
652
          ()
653
      in
654
      assert false
655
    (* The mutation has not been performed. *)
656
  in
657

    
658
  (* target := None; (* should happen only if no mutation occured during the
659
     visit *)*)
660
  prog', mutation_info
661

    
662
let op_mutation op =
663
  let res =
664
    let rem_op l = List.filter (fun e -> e <> op) l in
665
    if List.mem op arith_op then rem_op arith_op
666
    else if List.mem op bool_op then rem_op bool_op
667
    else if List.mem op rel_op then rem_op rel_op
668
    else (
669
      Format.eprintf "Failing with op %s@." op;
670
      assert false)
671
  in
672
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:","
673
     Format.pp_print_string) res; *)
674
  res
675

    
676
let rec remains select list =
677
  match list with
678
  | [] ->
679
    []
680
  | hd :: tl ->
681
    if select hd then tl else remains select tl
682

    
683
let next_change m =
684
  let res =
685
    let rec first_op () =
686
      try
687
        let min_binding = OpCount.min_binding !records.nb_op in
688
        Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
689
      with Not_found -> first_boolexpr ()
690
    and first_boolexpr () =
691
      if !records.nb_boolexpr > 0 then Boolexpr 0 else first_pre ()
692
    and first_pre () = if !records.nb_pre > 0 then Pre 0 else first_op ()
693
    and first_intcst () =
694
      if IntSet.cardinal !records.consts > 0 then IncrIntCst 0
695
      else first_boolexpr ()
696
    in
697
    match m with
698
    | Boolexpr n ->
699
      if n + 1 >= !records.nb_boolexpr then first_pre () else Boolexpr (n + 1)
700
    | Pre n ->
701
      if n + 1 >= !records.nb_pre then first_op () else Pre (n + 1)
702
    | Op (orig, id, mut_op) -> (
703
      match remains (fun x -> x = mut_op) (op_mutation orig) with
704
      | next_op :: _ ->
705
        Op (orig, id, next_op)
706
      | [] ->
707
        if id + 1 >= OpCount.find orig !records.nb_op then
708
          match
709
            remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op)
710
          with
711
          | [] ->
712
            first_intcst ()
713
          | hd :: _ ->
714
            Op (fst hd, 0, List.hd (op_mutation (fst hd)))
715
        else Op (orig, id + 1, List.hd (op_mutation orig)))
716
    | IncrIntCst n ->
717
      if n + 1 >= IntSet.cardinal !records.consts then DecrIntCst 0
718
      else IncrIntCst (n + 1)
719
    | DecrIntCst n ->
720
      if n + 1 >= IntSet.cardinal !records.consts then SwitchIntCst (0, 0)
721
      else DecrIntCst (n + 1)
722
    | SwitchIntCst (n, m) ->
723
      if m + 1 > -1 + IntSet.cardinal !records.consts then
724
        SwitchIntCst (n, m + 1)
725
      else if n + 1 >= IntSet.cardinal !records.consts then
726
        SwitchIntCst (n + 1, 0)
727
      else first_boolexpr ()
728
  in
729

    
730
  (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
731
  res
732

    
733
let fold_mutate nb prog =
734
  incr random_seed;
735
  Random.init !random_seed;
736

    
737
  (* Local references to keep track of generated directives *)
738

    
739
  (* build a set of integer 0, 1, ... n-1 for input n *)
740
  let cpt_to_intset cpt =
741
    let arr = Array.init cpt (fun x -> x) in
742
    Array.fold_right IntSet.add arr IntSet.empty
743
  in
744

    
745
  let possible_const_id = cpt_to_intset !records.nb_consts in
746

    
747
  (* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)
748
  (* let possible_pre_id = cpt_to_intset !records.nb_pre in *)
749
  let incremented_const_id = ref IntSet.empty in
750
  let decremented_const_id = ref IntSet.empty in
751

    
752
  let create_new_incr_decr registered build =
753
    let possible =
754
      IntSet.diff possible_const_id !registered |> IntSet.elements
755
    in
756
    let len = List.length possible in
757
    if len <= 0 then false, build (-1) (* Should not be stored *)
758
    else
759
      let picked = List.nth possible (Random.int (List.length possible)) in
760
      registered := IntSet.add picked !registered;
761
      true, build picked
762
  in
763

    
764
  let module DblIntSet = Set.Make (struct
765
    type t = int * int
766

    
767
    let compare = compare
768
  end) in
769
  let switch_const_id = ref DblIntSet.empty in
770
  let switch_set =
771
    if IntSet.cardinal !records.consts <= 1 then DblIntSet.empty
772
    else
773
      (* First element is cst id (the ith cst) while second is the ith element
774
         of the set of gathered constants !record.consts *)
775
      IntSet.fold
776
        (fun cst_id set ->
777
          IntSet.fold
778
            (fun ith_cst set -> DblIntSet.add (cst_id, ith_cst) set)
779
            !records.consts set)
780
        possible_const_id DblIntSet.empty
781
  in
782

    
783
  let create_new_switch registered build =
784
    let possible =
785
      DblIntSet.diff switch_set !registered |> DblIntSet.elements
786
    in
787
    let len = List.length possible in
788
    if len <= 0 then false, build (-1, -1) (* Should not be stored *)
789
    else
790
      let picked = List.nth possible (Random.int (List.length possible)) in
791
      registered := DblIntSet.add picked !registered;
792
      true, build picked
793
  in
794

    
795
  let find_next_new mutants mutant =
796
    let find_next_new init current =
797
      if init = current || List.mem current mutants then raise Not_found
798
      else
799
        (* TODO: check if we can generate more cases. The following lines were
800
           cylcing and missing to detect that the enumaration was complete,
801
           leading to a non terminating process. The current setting is harder
802
           but may miss enumerating some cases. To be checked! *)
803

    
804
        (* if List.mem current mutants then *)
805
        (*   find_next_new init (next_change current) *)
806
        (* else *)
807
        current
808
    in
809
    find_next_new mutant (next_change mutant)
810
  in
811
  (* Creating list of nb elements of mutants *)
812
  let rec create_mutants_directives rnb mutants =
813
    if rnb <= 0 then mutants
814
    else
815
      (* Initial list of transformation *)
816
      let rec init_list x = if x <= 0 then [ 0 ] else x :: init_list (x - 1) in
817
      let init_list = init_list 5 in
818
      (* We generate a random permutation of the list: the first item is the
819
         transformation, the rest of the list act as fallback choices to make
820
         sure we produce something *)
821
      let shuffle l =
822
        let nd = List.map (fun c -> Random.bits (), c) l in
823
        let sond = List.sort compare nd in
824
        List.map snd sond
825
      in
826
      let transforms = shuffle init_list in
827
      let rec apply_transform transforms =
828
        let f id =
829
          match id with
830
          | 5 ->
831
            create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x)
832
          | 4 ->
833
            create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x)
834
          | 3 ->
835
            create_new_switch switch_const_id (fun (x, y) ->
836
                SwitchIntCst (x, y))
837
          | 2 ->
838
            ( !records.nb_pre > 0,
839
              Pre (try Random.int !records.nb_pre with _ -> 0) )
840
          | 1 ->
841
            ( !records.nb_boolexpr > 0,
842
              Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0) )
843
          | 0 ->
844
            let bindings = OpCount.bindings !records.nb_op in
845
            let bindings_len = List.length bindings in
846
            if bindings_len > 0 then
847
              let op, nb_op =
848
                List.nth bindings (try Random.int bindings_len with _ -> 0)
849
              in
850
              let op_mut = op_mutation op in
851
              let new_op =
852
                List.nth op_mut
853
                  (try Random.int (List.length op_mut) with _ -> 0)
854
              in
855
              true, Op (op, (try Random.int nb_op with _ -> 0), new_op)
856
            else false, Boolexpr 0
857
          (* Providing a dummy construct, it will be filtered out thanks to the
858
             negative status (fst = false) *)
859
          | _ ->
860
            assert false
861
        in
862
        match transforms with
863
        | [] ->
864
          assert false
865
        | [ hd ] ->
866
          f hd
867
        | hd :: tl ->
868
          let ok, random_mutation = f hd in
869
          if ok then ok, random_mutation else apply_transform tl
870
      in
871
      let ok, random_mutation = apply_transform transforms in
872
      let stop_process () =
873
        report ~level:1 (fun fmt ->
874
            fprintf fmt
875
              "Only %i mutants directives generated out of %i expected@ "
876
              (nb - rnb) nb);
877
        mutants
878
      in
879
      if not ok then stop_process ()
880
      else if List.mem random_mutation mutants then
881
        try
882
          let new_mutant = find_next_new mutants random_mutation in
883
          report ~level:2 (fun fmt ->
884
              fprintf fmt " %i mutants directive generated out of %i expected@ "
885
                (nb - rnb) nb);
886
          create_mutants_directives (rnb - 1) (new_mutant :: mutants)
887
        with Not_found -> stop_process ()
888
      else create_mutants_directives (rnb - 1) (random_mutation :: mutants)
889
  in
890
  let mutants_directives = create_mutants_directives nb [] in
891
  List.map
892
    (fun d ->
893
      let mutant, loc = create_mutant prog d in
894
      d, loc, mutant)
895
    mutants_directives
896

    
897
let mutate nb prog =
898
  records := compute_records prog;
899
  (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
900
  (*   !records.nb_pre *)
901
  (*     !records.nb_boolexpr *)
902
  (*     (\* !records.op *\) *)
903
  (* ;  *)
904
  fold_mutate nb prog
905

    
906
(* Local Variables: *)
907
(* compile-command:"make -C .." *)
908
(* End: *)
(42-42/66)