Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/mutation.ml
1

  
2 1
(* Comments in function fold_mutate
3 2

  
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

  
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! *)
12 7

  
13 8
open Lustre_types
14 9
open Corelang
......
16 11
open Format
17 12

  
18 13
let random_seed = ref 0
14

  
19 15
let threshold_delay = 95
16

  
20 17
let threshold_inc_int = 97
18

  
21 19
let threshold_dec_int = 97
20

  
22 21
let threshold_random_int = 96
23
let threshold_switch_int = 100 (* not implemented yet *)
24
let threshold_random_float = 100 (* not used yet *)
22

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

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

  
25 29
let threshold_negate_bool_var = 95
30

  
26 31
let threshold_arith_op = 95
32

  
27 33
let threshold_rel_op = 95
34

  
28 35
let threshold_bool_op = 95
29 36

  
30 37
let int_consts = ref []
31 38

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

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

  
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)
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)
54 64

  
55 65
type records = {
56
  consts: IntSet.t;
57
  nb_consts: int;
58
  nb_boolexpr: int;
59
  nb_pre: int;
60
  nb_op: int OpCount.t;
66
  consts : IntSet.t;
67
  nb_consts : int;
68
  nb_boolexpr : int;
69
  nb_pre : int;
70
  nb_op : int OpCount.t;
61 71
}
62 72

  
63
let arith_op = ["+" ; "-" ; "*" ; "/"] 
64
let bool_op = ["&&"; "||"; "xor";  "impl"] 
65
let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ] 
73
let arith_op = [ "+"; "-"; "*"; "/" ]
74

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

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

  
66 79
let ops = arith_op @ bool_op @ rel_op
80

  
67 81
let all_ops = "not" :: ops
68 82

  
69
let empty_records = 
70
  {consts=IntSet.empty; nb_consts=0; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
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
  }
71 91

  
72 92
let records = ref empty_records
73 93

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

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

  
83
      nb_op = OpCount.merge (fun _ 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 
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;
89 112
    }
90 113
  in
91 114
  List.fold_left merge_record empty_records records_list
92
  
115

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

  
98 123
let rec compute_records_expr expr =
99
  let boolexpr = 
124
  let boolexpr =
100 125
    if Types.is_bool_type expr.expr_type then
101
      {empty_records with nb_boolexpr = 1}
102
    else
103
      empty_records
126
      { empty_records with nb_boolexpr = 1 }
127
    else empty_records
104 128
  in
105
  let subrec = 
129
  let subrec =
106 130
    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])
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 ]
117 142
    | Expr_appl (op_id, args, _) ->
118 143
      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
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
125 152
  in
126
  merge_records [boolexpr;subrec]
153
  merge_records [ boolexpr; subrec ]
127 154

  
128 155
let compute_records_eq eq = compute_records_expr eq.eq_rhs
129 156

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

  
135 163
let compute_records_top_decl td =
136 164
  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 = 
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 =
142 173
  merge_records (List.map compute_records_top_decl prog)
143 174

  
144 175
(*****************************************************************)
......
148 179
let check_mut e1 e2 =
149 180
  let rec eq e1 e2 =
150 181
    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
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
159 198
  in
160
  if not (eq e1 e2) then
161
    Some (e1, e2)
162
  else
163
    None
199
  if not (eq e1 e2) then Some (e1, e2) else None
164 200

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

  
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
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
174 207
  else if Random.int 100 > threshold_switch_int then
175 208
    let idx = Random.int (List.length !int_consts) in
176 209
    List.nth !int_consts idx
177
  else
178
    i
179
  
210
  else i
211

  
180 212
let rdm_mutate_real r =
181 213
  if Random.int 100 > threshold_random_float then
182 214
    (* interval [0, bound] for random values *)
......
185 217
    let digits = 5 in
186 218
    (* number of digits after comma *)
187 219
    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
220
    let eshift = 10. ** float_of_int shift in
221
    let i = Random.int (1 + (bound * int_of_float eshift)) in
190 222
    let f = float_of_int i /. eshift in
191 223
    Real.create (string_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

  
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
208 244

  
209 245
let rdm_mutate_var expr =
210 246
  if Types.is_bool_type expr.expr_type then
211 247
    (* if Random.int 100 > threshold_negate_bool_var then *)
212
    let new_e = mkpredef_call expr.expr_loc "not" [expr] in
248
    let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
213 249
    Some (expr, new_e), new_e
214 250
    (* 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
251
    (*   expr *)
252
  else None, expr
222 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
223 257

  
224 258
let rdm_mutate_const_value c =
225 259
  match c with
226
  | Const_int i -> Const_int (rdm_mutate_int i)
227
  | Const_real r -> Const_real (rdm_mutate_real r)
260
  | Const_int i ->
261
    Const_int (rdm_mutate_int i)
262
  | Const_real r ->
263
    Const_real (rdm_mutate_real r)
228 264
  | Const_array _
229 265
  | Const_string _
230 266
  | Const_modeid _
231 267
  | Const_struct _
232
  | Const_tag _ -> c
268
  | Const_tag _ ->
269
    c
233 270

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

  
239

  
240
let select_in_list list rdm_mutate_elem = 
276
let select_in_list list rdm_mutate_elem =
241 277
  let selected = Random.int (List.length list) in
242
  let mutation_opt, new_list, _ = 
278
  let mutation_opt, new_list, _ =
243 279
    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)
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)
249 286
  in
250
  match mutation_opt with
251
  | Some mut -> mut, new_list
252
  | _ -> assert false
253

  
287
  match mutation_opt with Some mut -> mut, new_list | _ -> assert false
254 288

  
255 289
let rec rdm_mutate_expr expr =
256 290
  let mk_e d = { expr with expr_desc = d } in
257 291
  match expr.expr_desc with
258
  | Expr_ident _ -> rdm_mutate_var expr
259
  | Expr_const c -> 
260
    let new_const = rdm_mutate_const_value c in 
292
  | Expr_ident _ ->
293
    rdm_mutate_var expr
294
  | Expr_const c ->
295
    let new_const = rdm_mutate_const_value c in
261 296
    let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
262 297
    mut, mk_e (Expr_const new_const)
263
  | Expr_tuple l -> 
298
  | Expr_tuple l ->
264 299
    let mut, l' = select_in_list l rdm_mutate_expr in
265 300
    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
301
  | Expr_ite (i, t, e) -> (
302
    let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
268 303
    match l with
269
    | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e'))
270
    | _ -> assert false
271
  )
304
    | [ i'; t'; e' ] ->
305
      mut, mk_e (Expr_ite (i', t', e'))
306
    | _ ->
307
      assert false)
272 308
  | Expr_arrow (e1, e2) -> (
273
    let mut, l = select_in_list [e1; e2] rdm_mutate_expr in
309
    let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
274 310
    match l with
275
    | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2'))
276
    | _ -> assert false
277
  )
278
  | Expr_pre e -> 
311
    | [ e1'; e2' ] ->
312
      mut, mk_e (Expr_arrow (e1', e2'))
313
    | _ ->
314
      assert false)
315
  | Expr_pre e ->
279 316
    let select_pre = Random.bool () in
280 317
    if select_pre then
281 318
      let mut, new_expr = rdm_mutate_pre expr in
......
283 320
    else
284 321
      let mut, e' = rdm_mutate_expr e in
285 322
      mut, mk_e (Expr_pre e')
286
  | Expr_appl (op_id, args, r) -> 
323
  | Expr_appl (op_id, args, r) ->
287 324
    let select_op = Random.bool () in
288 325
    if select_op then
289 326
      let new_op_id = rdm_mutate_op op_id in
......
293 330
    else
294 331
      let mut, new_args = rdm_mutate_expr args in
295 332
      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
  
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
308 340

  
309 341
let rdm_mutate_eq eq =
310 342
  let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
......
312 344

  
313 345
let rnd_mutate_stmt stmt =
314 346
  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 _ -> 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
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
328 358
  mutation, { nd with node_stmts = new_node_stmts }
329 359

  
330 360
let rdm_mutate_top_decl td =
331 361
  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 -> 
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 ->
336 366
    let mut, new_cst = rdm_mutate_const cst in
337 367
    mut, { td with top_decl_desc = Const new_cst }
338
  | _ -> None, td
339
    
368
  | _ ->
369
    None, td
370

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

  
344
let rdm_mutate nb prog = 
374
let rdm_mutate nb prog =
345 375
  let rec iterate nb res =
346 376
    incr random_seed;
347
    if nb <= 0 then
348
      res
377
    if nb <= 0 then res
349 378
    else (
350 379
      Random.init !random_seed;
351 380
      let mutation, new_mutant = rdm_mutate_prog prog in
352 381
      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
    )
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)))
364 389
  in
365 390
  iterate nb []
366 391

  
367

  
368 392
(*****************************************************************)
369 393
(*                  Random mutation                              *)
370 394
(*****************************************************************)
......
375 399
  | Op of string * int * string
376 400
  | IncrIntCst of int
377 401
  | DecrIntCst of int
378
  | SwitchIntCst of int * int 
402
  | SwitchIntCst of int * int
379 403

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

  
382 407
let target : mutant_t option ref = ref None
383 408

  
384 409
let mutation_info : mutation_loc option ref = ref None
385
let current_node: ident option ref = ref None 
410

  
411
let current_node : ident option ref = ref None
412

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

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

  
389 417
let set_mutation_loc () =
390 418
  target := None;
391 419
  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 *)
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 *)
395 425

  
396 426
let print_directive fmt d =
397 427
  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
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
404 440

  
405 441
let print_directive_json fmt d =
406 442
  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 _ ->  Format.fprintf fmt "\"mutation\": \"cst_incr\""
411
  | DecrIntCst _ ->  Format.fprintf fmt "\"mutation\": \"cst_decr\""
412
  | SwitchIntCst (_, 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
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
427 467
  else if Random.int 100 > threshold_switch_int then
428 468
    try
429
	let idx = Random.int (List.length !int_consts) in
430
        List.nth !int_consts idx
469
      let idx = Random.int (List.length !int_consts) in
470
      List.nth !int_consts idx
431 471
    with _ -> i
432
  else
433
    i
434
  
472
  else i
473

  
435 474
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 *)
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 *)
453 492
  match !target with
454
  | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
493
  | Some (Op (op_orig, 0, op_new)) when op_orig = op ->
455 494
    set_mutation_loc ();
456 495
    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));
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
  | _ ->
460 500
    op
461
  )
462
  | _ -> op
463

  
464 501

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

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

  
480
    mkpredef_call expr.expr_loc "not" [expr]
481
  )
517
    mkpredef_call expr.expr_loc "not" [ expr ]
482 518
  | Some (Boolexpr n) ->
483
      (target := Some (Boolexpr (n-1)); expr)
484
  | _ -> expr
485
    
486
let fold_mutate_pre orig_expr e = 
519
    target := Some (Boolexpr (n - 1));
520
    expr
521
  | _ ->
522
    expr
523

  
524
let fold_mutate_pre orig_expr e =
487 525
  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));
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
  | _ ->
494 533
    Expr_pre e
495
  )
496
  | _ -> Expr_pre e
497
    
534

  
498 535
let fold_mutate_const_value c =
499 536
  match c with
500 537
  | Const_int i -> (
501 538
    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))
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)
504 545
    | 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
				  *)
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 *)
522 565
let fold_mutate_const c =
523 566
  { c with const_value = fold_mutate_const_value c.const_value }
524 567

  
525 568
let rec fold_mutate_expr expr =
526 569
  current_loc := Some expr.expr_loc;
527
  let new_expr = 
570
  let new_expr =
528 571
    match expr.expr_desc with
529
    | Expr_ident _ -> 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
    
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
550 597
      in
598

  
551 599
      { expr with expr_desc = new_desc }
552
    )
553 600
  in
554
  if Types.is_bool_type expr.expr_type then
555
    fold_mutate_boolexpr new_expr  
556
  else
557
    new_expr
601
  if Types.is_bool_type expr.expr_type then fold_mutate_boolexpr new_expr
602
  else new_expr
558 603

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

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

  
609
  match stmt with Eq eq -> Eq (fold_mutate_eq eq) | Aut _ -> assert false
568 610

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

  
579 624
let fold_mutate_top_decl td =
580 625
  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
    
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

  
585 633
(* 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 []
634
let fold_mutate_prog prog =
635
  List.fold_right (fun e res -> fold_mutate_top_decl e :: res) prog []
588 636

  
589
let create_mutant prog directive =  
590
  target := Some directive; 
637
let create_mutant prog directive =
638
  target := Some directive;
591 639
  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
     
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. *)
600 656
  in
601
(*  target := None; (* should happen only if no mutation occured during the
602
    visit *)*)
657

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

  
606
let op_mutation op = 
662
let op_mutation op =
607 663
  let res =
608 664
    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
	)
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)
615 671
  in
616
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
672
  (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:","
673
     Format.pp_print_string) res; *)
617 674
  res
618 675

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

  
624 683
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 ()
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 ()
645 728
  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 729

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

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

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

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

  
696 745
  let possible_const_id = cpt_to_intset !records.nb_consts in
746

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

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

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

  
715
  let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in
767
    let compare = compare
768
  end) in
716 769
  let switch_const_id = ref DblIntSet.empty in
717 770
  let switch_set =
718
    if IntSet.cardinal !records.consts <= 1 then
719
      DblIntSet.empty
771
    if IntSet.cardinal !records.consts <= 1 then DblIntSet.empty
720 772
    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 
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
729 781
  in
730 782

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

  
742 795
  let find_next_new mutants mutant =
743 796
    let 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
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
755 808
    in
756
    find_next_new mutant (next_change mutant) 
809
    find_next_new mutant (next_change mutant)
757 810
  in
758 811
  (* Creating list of nb elements of mutants *)
759
  let rec create_mutants_directives rnb mutants = 
760
    if rnb <= 0 then mutants 
812
  let rec create_mutants_directives rnb mutants =
813
    if rnb <= 0 then mutants
761 814
    else
762 815
      (* Initial list of transformation *)
763
      let rec init_list x = if x <= 0 then [0] else x::(init_list (x-1)) in
816
      let rec init_list x = if x <= 0 then [ 0 ] else x :: init_list (x - 1) in
764 817
      let init_list = init_list 5 in
765 818
      (* 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 *)
819
         transformation, the rest of the list act as fallback choices to make
820
         sure we produce something *)
768 821
      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
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
772 825
      in
773 826
      let transforms = shuffle init_list in
774 827
      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
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
804 870
      in
805 871
      let ok, random_mutation = apply_transform transforms in
806 872
      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
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
812 878
      in
813
      if not ok then
814
	stop_process ()
879
      if not ok then stop_process ()
815 880
      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
      )
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)
826 889
  in
827 890
  let mutants_directives = create_mutants_directives nb [] in
828
  List.map (fun d ->
891
  List.map
892
    (fun d ->
829 893
      let mutant, loc = create_mutant prog d in
830
      d, loc, mutant ) mutants_directives 
831
  
894
      d, loc, mutant)
895
    mutants_directives
832 896

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

  
842

  
843

  
901
  (*     !records.nb_boolexpr *)
902
  (*     (\* !records.op *\) *)
903
  (* ;  *)
904
  fold_mutate nb prog
844 905

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

  
849
    

Also available in: Unified diff