Project

General

Profile

Download (5.81 KB) Statistics
| Branch: | Tag: | Revision:
1
open Corelang
2
open Log
3
open Format
4

    
5
let random_seed = ref 0
6
let threshold_delay = 95
7
let threshold_inc_int = 97
8
let threshold_dec_int = 97
9
let threshold_random_int = 96
10
let threshold_switch_int = 100 (* not implemented yet *)
11
let threshold_random_float = 100 (* not used yet *)
12
let threshold_negate_bool_var = 95
13
let threshold_arith_op = 95
14
let threshold_rel_op = 95
15
let threshold_bool_op = 95
16

    
17
let int_consts = ref []
18

    
19
(************************************************************************************)
20

    
21

    
22

    
23
let mutate_pre orig_expr e = 
24
  if Random.int 100 <= threshold_delay then
25
    (* We do not nothing *)
26
    Expr_pre e 
27
  else (* We add a pre *)
28
    Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
29

    
30

    
31
let get_int_consts_const_value c =
32
  match c with
33
  | Const_int i -> [i]
34
  | _ -> []
35

    
36
let get_int_consts_const c = get_int_consts_const_value c.const_value 
37

    
38
let rec get_int_consts_expr expr =
39
  match expr.expr_desc with
40
  | Expr_const c -> get_int_consts_const_value c
41
  | Expr_tuple l -> List.flatten (List.map get_int_consts_expr l)
42
  | Expr_ite (i,t,e) -> get_int_consts_expr i @ get_int_consts_expr e @ get_int_consts_expr t
43
  | Expr_arrow (e1, e2) -> get_int_consts_expr e1 @ get_int_consts_expr e2
44
  | Expr_pre e -> get_int_consts_expr e
45
  | Expr_appl (op_id, args, r) -> get_int_consts_expr args
46
  | _ -> []
47

    
48
let get_int_consts_eq eq = get_int_consts_expr eq.eq_rhs
49

    
50
let get_int_consts_node nd = List.flatten (List.map get_int_consts_eq nd.node_eqs)
51

    
52
let get_int_consts_top_decl td =
53
  match td.top_decl_desc with
54
  | Node nd -> get_int_consts_node nd
55
  | Consts constsl -> List.flatten (List.map get_int_consts_const constsl)
56
  | _ -> []
57

    
58
let get_int_consts prog = 
59
  List.flatten (List.map get_int_consts_top_decl prog)
60
(***************************************************************)
61

    
62
let mutate_int i = 
63
  if Random.int 100 > threshold_inc_int then
64
    i+1
65
  else if Random.int 100 > threshold_dec_int then
66
    i-1
67
  else if Random.int 100 > threshold_random_int then
68
    Random.int 10
69
  else if Random.int 100 > threshold_switch_int then
70
    let idx = Random.int (List.length !int_consts) in
71
    List.nth !int_consts idx
72
  else
73
    i
74
  
75
let mutate_float f =
76
  if Random.int 100 > threshold_random_float then
77
    Random.float 10.
78
  else 
79
    f
80

    
81
let mutate_op op = 
82
match op with
83
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
84
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
85
  List.nth filtered (Random.int 3)
86
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
87
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
88
  List.nth filtered (Random.int 3)
89
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
90
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
91
  List.nth filtered (Random.int 5)
92
| _ -> op
93

    
94

    
95
let mutate_var expr = 
96
  match (Types.repr expr.expr_type).Types.tdesc with 
97
  | Types.Tbool ->
98
    if Random.int 100 > threshold_negate_bool_var then
99
      mkpredef_unary_call Location.dummy_loc "not" expr
100
    else 
101
      expr
102
  | _ -> expr
103
    
104
let mutate_pre orig_expr e = 
105
  if Random.int 100 <= threshold_delay then
106
    (* We do not nothing *)
107
    Expr_pre e 
108
  else (* We add a pre *)
109
    Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
110

    
111

    
112
let mutate_const_value c =
113
  match c with
114
  | Const_int i -> Const_int (mutate_int i)
115
  | Const_real s -> Const_real s (* those are string, let's leave them *)
116
  | Const_float f -> Const_float (mutate_float f)
117
  | Const_array _
118
  | Const_tag _ -> c
119

    
120
let mutate_const c =
121
  { c with const_value = mutate_const_value c.const_value }
122

    
123

    
124
let select_in_list list mutate_elem = 
125
  let selected = Random.int (List.length list) in
126
  let new_list, _ = 
127
    List.fold_right
128
      (fun elem (res, cpt) -> if cpt = selected then (mutate_elem elem)::res, cpt+1  else elem::res, cpt+1)
129
      list 
130
      ([], 0)
131
  in
132
  new_list
133

    
134
let rec mutate_expr expr =
135
  match expr.expr_desc with
136
  | Expr_ident id -> mutate_var expr
137
  | _ -> (
138
    let new_desc = match expr.expr_desc with
139
      | Expr_const c -> Expr_const (mutate_const_value c)
140
      | Expr_tuple l -> Expr_tuple (List.map mutate_expr l)
141
      | Expr_ite (i,t,e) -> Expr_ite (mutate_expr i, mutate_expr t, mutate_expr e)
142
      | Expr_arrow (e1, e2) -> Expr_arrow (mutate_expr e1, mutate_expr e2)
143
      | Expr_pre e -> mutate_pre expr (mutate_expr e)
144
      | Expr_appl (op_id, args, r) -> Expr_appl (mutate_op op_id, mutate_expr args, r)
145
  (* Other constructs are kept.
146
  | Expr_fby of expr * expr
147
  | Expr_array of expr list
148
  | Expr_access of expr * Dimension.dim_expr
149
  | Expr_power of expr * Dimension.dim_expr
150
  | Expr_when of expr * ident * label
151
  | Expr_merge of ident * (label * expr) list
152
  | Expr_uclock of expr * int
153
  | Expr_dclock of expr * int
154
  | Expr_phclock of expr * rat *)
155
  | _ -> expr.expr_desc
156

    
157
    in
158
    { expr with expr_desc = new_desc }
159
  )
160

    
161
let mutate_eq eq =
162
  { eq with eq_rhs = mutate_expr eq.eq_rhs }
163

    
164
let mutate_node nd = 
165
  { nd with node_eqs = select_in_list nd.node_eqs mutate_eq }
166

    
167
let mutate_top_decl td =
168
  match td.top_decl_desc with
169
  | Node nd -> { td with top_decl_desc = Node (mutate_node nd)}
170
  | Consts constsl -> { td with top_decl_desc = Consts (List.map mutate_const constsl)}
171
  | _ -> td
172
    
173
(* Create a single mutant with the provided random seed *)
174
let mutate_prog prog = 
175
  select_in_list prog mutate_top_decl
176

    
177
let mutate nb prog = 
178
  int_consts := get_int_consts prog;
179
  let rec iterate nb res =
180
    incr random_seed;
181
    if nb <= 0 then
182
      res
183
    else (
184
      Random.init !random_seed;
185
      let new_mutant = mutate_prog prog in
186
      if List.mem new_mutant res then (
187
	report ~level:1 (fun fmt -> fprintf fmt "New mutant is not new %i@." nb);
188
	iterate nb res
189
      )
190
      else
191
	iterate (nb-1) (new_mutant::res)
192
    )
193
  in
194
  iterate nb []
195

    
196

    
197

    
198

    
199
(* Local Variables: *)
200
(* compile-command:"make -C .." *)
201
(* End: *)
202

    
203
    
(32-32/46)