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