Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / mutation.ml @ f30a2012

History | View | Annotate | Download (4.05 KB)

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 mutate_int i = 
18
  if Random.int 100 > threshold_inc_int then
19
    i+1
20
  else if Random.int 100 > threshold_dec_int then
21
    i-1
22
  else if Random.int 100 > threshold_random_int then
23
    Random.int 10
24
  else if Random.int 100 > threshold_switch_int then
25
    assert false
26
  else
27
    i
28
  
29
let mutate_float f =
30
  if Random.int 100 > threshold_random_float then
31
    Random.float 10.
32
  else 
33
    f
34

    
35
let mutate_op op = 
36
match op with
37
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
38
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
39
  List.nth filtered (Random.int 3)
40
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
41
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
42
  List.nth filtered (Random.int 3)
43
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
44
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
45
  List.nth filtered (Random.int 5)
46
| _ -> op
47

    
48

    
49
let mutate_var expr = 
50
  match (Types.repr expr.expr_type).Types.tdesc with 
51
  | Types.Tbool ->
52
    if Random.int 100 > threshold_negate_bool_var then
53
      mkpredef_unary_call Location.dummy_loc "not" expr
54
    else 
55
      expr
56
  | _ -> expr
57
    
58
let mutate_pre orig_expr e = 
59
  if Random.int 100 <= threshold_delay then
60
    (* We do not nothing *)
61
    Expr_pre e 
62
  else (* We add a pre *)
63
    Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
64

    
65

    
66
let mutate_const_value c =
67
  match c with
68
  | Const_int i -> Const_int (mutate_int i)
69
  | Const_real s -> Const_real s (* those are string, let's leave them *)
70
  | Const_float f -> Const_float (mutate_float f)
71
  | Const_array _
72
  | Const_tag _ -> c
73

    
74
let mutate_const c =
75
  { c with const_value = mutate_const_value c.const_value }
76

    
77

    
78
let rec mutate_expr expr =
79
  match expr.expr_desc with
80
  | Expr_ident id -> mutate_var expr
81
  | _ -> (
82
    let new_desc = match expr.expr_desc with
83
      | Expr_const c -> Expr_const (mutate_const_value c)
84
      | Expr_tuple l -> Expr_tuple (List.map mutate_expr l)
85
      | Expr_ite (i,t,e) -> Expr_ite (mutate_expr i, mutate_expr t, mutate_expr e)
86
      | Expr_arrow (e1, e2) -> Expr_arrow (mutate_expr e1, mutate_expr e2)
87
      | Expr_pre e -> mutate_pre expr (mutate_expr e)
88
      | Expr_appl (op_id, args, r) -> Expr_appl (mutate_op op_id, mutate_expr args, r)
89
  (* Other constructs are kept.
90
  | Expr_fby of expr * expr
91
  | Expr_array of expr list
92
  | Expr_access of expr * Dimension.dim_expr
93
  | Expr_power of expr * Dimension.dim_expr
94
  | Expr_when of expr * ident * label
95
  | Expr_merge of ident * (label * expr) list
96
  | Expr_uclock of expr * int
97
  | Expr_dclock of expr * int
98
  | Expr_phclock of expr * rat *)
99
  | _ -> expr.expr_desc
100

    
101
    in
102
    { expr with expr_desc = new_desc }
103
  )
104

    
105
let mutate_eq eq =
106
  { eq with eq_rhs = mutate_expr eq.eq_rhs }
107

    
108
let mutate_node nd = 
109
  { nd with node_eqs = List.map mutate_eq nd.node_eqs }
110

    
111
let mutate_top_decl td =
112
  match td.top_decl_desc with
113
  | Node nd -> { td with top_decl_desc = Node (mutate_node nd)}
114
  | Consts constsl -> { td with top_decl_desc = Consts (List.map mutate_const constsl)}
115
  | _ -> td
116
    
117
(* Create a single mutant with the provided random seed *)
118
let mutate_prog prog = 
119
  List.map mutate_top_decl prog
120

    
121
let rec mutate nb prog = 
122
  let rec iterate nb res =
123
    incr random_seed;
124
    if nb <= 0 then
125
      res
126
    else (
127
      Random.init !random_seed;
128
      let new_mutant = mutate_prog prog in
129
      if List.mem new_mutant res then (
130
	report ~level:1 (fun fmt -> fprintf fmt "New mutant is not new %i@." nb);
131
	iterate nb res
132
      )
133
      else
134
	iterate (nb-1) (new_mutant::res)
135
    )
136
  in
137
  iterate nb []
138

    
139

    
140

    
141

    
142
(* Local Variables: *)
143
(* compile-command:"make -C .." *)
144
(* End: *)
145

    
146