1

open LustreSpec

2

open Corelang

3

open Log

4

open Format

5


6

let random_seed = ref 0

7

let threshold_delay = 95

8

let threshold_inc_int = 97

9

let threshold_dec_int = 97

10

let threshold_random_int = 96

11

let threshold_switch_int = 100 (* not implemented yet *)

12

let threshold_random_float = 100 (* not used yet *)

13

let threshold_negate_bool_var = 95

14

let threshold_arith_op = 95

15

let threshold_rel_op = 95

16

let threshold_bool_op = 95

17


18

let int_consts = ref []

19


20

let rename_app id =

21

if !Options.no_mutation_suffix then

22

id

23

else

24

id ^ "_mutant"

25


26

(************************************************************************************)

27

(* Gathering constants in the code *)

28

(************************************************************************************)

29


30

module IntSet = Set.Make (struct type t = int let compare = compare end)

31

module OpCount = Mmap.Make (struct type t = string let compare = compare end)

32


33

type records = {

34

consts: IntSet.t;

35

nb_boolexpr: int;

36

nb_pre: int;

37

nb_op: int OpCount.t;

38

}

39


40

let arith_op = ["+" ; "" ; "*" ; "/"]

41

let bool_op = ["&&"; ""; "xor"; "impl"]

42

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

43

let ops = arith_op @ bool_op @ rel_op

44

let all_ops = "not" :: ops

45


46

let empty_records =

47

{consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}

48


49

let records = ref empty_records

50


51

let merge_records records_list =

52

let merge_record r1 r2 =

53

{

54

consts = IntSet.union r1.consts r2.consts;

55


56

nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;

57

nb_pre = r1.nb_pre + r2.nb_pre;

58


59

nb_op = OpCount.merge (fun op r1opt r2opt >

60

match r1opt, r2opt with

61

 None, _ > r2opt

62

 _, None > r1opt

63

 Some x, Some y > Some (x+y)

64

) r1.nb_op r2.nb_op

65

}

66

in

67

List.fold_left merge_record empty_records records_list

68


69

let compute_records_const_value c =

70

match c with

71

 Const_int i > {empty_records with consts = IntSet.singleton i}

72

 _ > empty_records

73


74

let rec compute_records_expr expr =

75

let boolexpr =

76

if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then

77

{empty_records with nb_boolexpr = 1}

78

else

79

empty_records

80

in

81

let subrec =

82

match expr.expr_desc with

83

 Expr_const c > compute_records_const_value c

84

 Expr_tuple l > merge_records (List.map compute_records_expr l)

85

 Expr_ite (i,t,e) >

86

merge_records (List.map compute_records_expr [i;t;e])

87

 Expr_arrow (e1, e2) >

88

merge_records (List.map compute_records_expr [e1;e2])

89

 Expr_pre e >

90

merge_records (

91

({empty_records with nb_pre = 1})

92

::[compute_records_expr e])

93

 Expr_appl (op_id, args, r) >

94

if List.mem op_id ops then

95

merge_records (

96

({empty_records with nb_op = OpCount.singleton op_id 1})

97

::[compute_records_expr args])

98

else

99

compute_records_expr args

100

 _ > empty_records

101

in

102

merge_records [boolexpr;subrec]

103


104

let compute_records_eq eq = compute_records_expr eq.eq_rhs

105


106

let compute_records_node nd =

107

merge_records (List.map compute_records_eq (get_node_eqs nd))

108


109

let compute_records_top_decl td =

110

match td.top_decl_desc with

111

 Node nd > compute_records_node nd

112

 Const cst > compute_records_const_value cst.const_value

113

 _ > empty_records

114


115

let compute_records prog =

116

merge_records (List.map compute_records_top_decl prog)

117


118

(*****************************************************************)

119

(* Random mutation *)

120

(*****************************************************************)

121


122

let check_mut e1 e2 =

123

let rec eq e1 e2 =

124

match e1.expr_desc, e2.expr_desc with

125

 Expr_const c1, Expr_const c2 > c1 = c2

126

 Expr_ident id1, Expr_ident id2 > id1 = id2

127

 Expr_tuple el1, Expr_tuple el2 > List.length el1 = List.length el2 && List.for_all2 eq el1 el2

128

 Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) > eq i1 i2 && eq t1 t2 && eq e1 e2

129

 Expr_arrow (x1, y1), Expr_arrow (x2, y2) > eq x1 x2 && eq y1 y2

130

 Expr_pre e1, Expr_pre e2 > eq e1 e2

131

 Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) > id1 = id2 && eq e1 e2

132

 _ > false

133

in

134

if not (eq e1 e2) then

135

Some (e1, e2)

136

else

137

None

138


139

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

140


141

let rdm_mutate_int i =

142

if Random.int 100 > threshold_inc_int then

143

i+1

144

else if Random.int 100 > threshold_dec_int then

145

i1

146

else if Random.int 100 > threshold_random_int then

147

Random.int 10

148

else if Random.int 100 > threshold_switch_int then

149

let idx = Random.int (List.length !int_consts) in

150

List.nth !int_consts idx

151

else

152

i

153


154

let rdm_mutate_real r =

155

if Random.int 100 > threshold_random_float then

156

(* interval [0, bound] for random values *)

157

let bound = 10 in

158

(* max number of digits after comma *)

159

let digits = 5 in

160

(* number of digits after comma *)

161

let shift = Random.int (digits + 1) in

162

let eshift = 10. ** (float_of_int shift) in

163

let i = Random.int (1 + bound * (int_of_float eshift)) in

164

let f = float_of_int i /. eshift in

165

(Num.num_of_int i, shift, string_of_float f)

166

else

167

r

168


169

let rdm_mutate_op op =

170

match op with

171

 "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op >

172

let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in

173

List.nth filtered (Random.int 3)

174

 "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op >

175

let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in

176

List.nth filtered (Random.int 3)

177

 "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op >

178

let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in

179

List.nth filtered (Random.int 5)

180

 _ > op

181


182


183

let rdm_mutate_var expr =

184

match (Types.repr expr.expr_type).Types.tdesc with

185

 Types.Tbool >

186

(* if Random.int 100 > threshold_negate_bool_var then *)

187

let new_e = mkpredef_call expr.expr_loc "not" [expr] in

188

Some (expr, new_e), new_e

189

(* else *)

190

(* expr *)

191

 _ > None, expr

192


193

let rdm_mutate_pre orig_expr =

194

let new_e = Expr_pre orig_expr in

195

Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e

196


197


198

let rdm_mutate_const_value c =

199

match c with

200

 Const_int i > Const_int (rdm_mutate_int i)

201

 Const_real (n, i, s) > let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s')

202

 Const_array _

203

 Const_string _

204

 Const_struct _

205

 Const_tag _ > c

206


207

let rdm_mutate_const c =

208

let new_const = rdm_mutate_const_value c.const_value in

209

let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in

210

mut, { c with const_value = new_const }

211


212


213

let select_in_list list rdm_mutate_elem =

214

let selected = Random.int (List.length list) in

215

let mutation_opt, new_list, _ =

216

List.fold_right

217

(fun elem (mutation_opt, res, cpt) > if cpt = selected then

218

let mutation, new_elem = rdm_mutate_elem elem in

219

Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1)

220

list

221

(None, [], 0)

222

in

223

match mutation_opt with

224

 Some mut > mut, new_list

225

 _ > assert false

226


227


228

let rec rdm_mutate_expr expr =

229

let mk_e d = { expr with expr_desc = d } in

230

match expr.expr_desc with

231

 Expr_ident id > rdm_mutate_var expr

232

 Expr_const c >

233

let new_const = rdm_mutate_const_value c in

234

let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in

235

mut, mk_e (Expr_const new_const)

236

 Expr_tuple l >

237

let mut, l' = select_in_list l rdm_mutate_expr in

238

mut, mk_e (Expr_tuple l')

239

 Expr_ite (i,t,e) > (

240

let mut, l = select_in_list [i; t; e] rdm_mutate_expr in

241

match l with

242

 [i'; t'; e'] > mut, mk_e (Expr_ite (i', t', e'))

243

 _ > assert false

244

)

245

 Expr_arrow (e1, e2) > (

246

let mut, l = select_in_list [e1; e2] rdm_mutate_expr in

247

match l with

248

 [e1'; e2'] > mut, mk_e (Expr_arrow (e1', e2'))

249

 _ > assert false

250

)

251

 Expr_pre e >

252

let select_pre = Random.bool () in

253

if select_pre then

254

let mut, new_expr = rdm_mutate_pre expr in

255

mut, mk_e new_expr

256

else

257

let mut, e' = rdm_mutate_expr e in

258

mut, mk_e (Expr_pre e')

259

 Expr_appl (op_id, args, r) >

260

let select_op = Random.bool () in

261

if select_op then

262

let new_op_id = rdm_mutate_op op_id in

263

let new_e = mk_e (Expr_appl (new_op_id, args, r)) in

264

let mut = check_mut expr new_e in

265

mut, new_e

266

else

267

let mut, new_args = rdm_mutate_expr args in

268

mut, mk_e (Expr_appl (op_id, new_args, r))

269

(* Other constructs are kept.

270

 Expr_fby of expr * expr

271

 Expr_array of expr list

272

 Expr_access of expr * Dimension.dim_expr

273

 Expr_power of expr * Dimension.dim_expr

274

 Expr_when of expr * ident * label

275

 Expr_merge of ident * (label * expr) list

276

 Expr_uclock of expr * int

277

 Expr_dclock of expr * int

278

 Expr_phclock of expr * rat *)

279

 _ > None, expr

280


281


282

let rdm_mutate_eq eq =

283

let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in

284

mutation, { eq with eq_rhs = new_rhs }

285


286

let rnd_mutate_stmt stmt =

287

match stmt with

288

 Eq eq > let mut, new_eq = rdm_mutate_eq eq in

289

report ~level:1

290

(fun fmt > fprintf fmt "mutation: %a becomes %a@."

291

Printers.pp_node_eq eq

292

Printers.pp_node_eq new_eq);

293

mut, Eq new_eq

294

 Aut aut > assert false

295


296

let rdm_mutate_node nd =

297

let mutation, new_node_stmts =

298

select_in_list

299

nd.node_stmts rnd_mutate_stmt

300

in

301

mutation, { nd with node_stmts = new_node_stmts }

302


303

let rdm_mutate_top_decl td =

304

match td.top_decl_desc with

305

 Node nd >

306

let mutation, new_node = rdm_mutate_node nd in

307

mutation, { td with top_decl_desc = Node new_node}

308

 Const cst >

309

let mut, new_cst = rdm_mutate_const cst in

310

mut, { td with top_decl_desc = Const new_cst }

311

 _ > None, td

312


313

(* Create a single mutant with the provided random seed *)

314

let rdm_mutate_prog prog =

315

select_in_list prog rdm_mutate_top_decl

316


317

let rdm_mutate nb prog =

318

let rec iterate nb res =

319

incr random_seed;

320

if nb <= 0 then

321

res

322

else (

323

Random.init !random_seed;

324

let mutation, new_mutant = rdm_mutate_prog prog in

325

match mutation with

326

None > iterate nb res

327

 Some mutation > (

328

if List.mem_assoc mutation res then (

329

iterate nb res

330

)

331

else (

332

report ~level:1 (fun fmt > fprintf fmt "%i mutants remaining@." nb);

333

iterate (nb1) ((mutation, new_mutant)::res)

334

)

335

)

336

)

337

in

338

iterate nb []

339


340


341

(*****************************************************************)

342

(* Random mutation *)

343

(*****************************************************************)

344


345

type mutant_t = Boolexpr of int  Pre of int  Op of string * int * string  IncrIntCst of int  DecrIntCst of int  SwitchIntCst of int * int

346


347

(* Denotes the parent node, the equation lhs and the location of the mutation *)

348

type mutation_loc = ident * ident list * Location.t

349

let target : mutant_t option ref = ref None

350


351

let mutation_info : mutation_loc option ref = ref None

352

let current_node: ident option ref = ref None

353

let current_eq_lhs : ident list option ref = ref None

354

let current_loc : Location.t option ref = ref None

355


356

let set_mutation_loc () =

357

target := None;

358

match !current_node, !current_eq_lhs, !current_loc with

359

 Some n, Some elhs, Some l > mutation_info := Some (n, elhs, l)

360

 _ > assert false (* Those global vars should be defined during the

361

visitor pattern execution *)

362


363

let print_directive fmt d =

364

match d with

365

 Pre n > Format.fprintf fmt "pre %i" n

366

 Boolexpr n > Format.fprintf fmt "boolexpr %i" n

367

 Op (o, i, d) > Format.fprintf fmt "%s %i > %s" o i d

368

 IncrIntCst n > Format.fprintf fmt "incr int cst %i" n

369

 DecrIntCst n > Format.fprintf fmt "decr int cst %i" n

370

 SwitchIntCst (n, m) > Format.fprintf fmt "switch int cst %i > %i" n m

371


372

let print_directive_json fmt d =

373

match d with

374

 Pre _ > Format.fprintf fmt "\"mutation\": \"pre\""

375

 Boolexpr _ > Format.fprintf fmt "\"mutation\": \"not\""

376

 Op (o, _, d) > Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d

377

 IncrIntCst n > Format.fprintf fmt "\"mutation\": \"cst_incr\""

378

 DecrIntCst n > Format.fprintf fmt "\"mutation\": \"cst_decr\""

379

 SwitchIntCst (n, m) > Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m

380


381

let print_loc_json fmt (n,eqlhs, l) =

382

Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\""

383

n

384

(Utils.fprintf_list ~sep:", " (fun fmt s > Format.fprintf fmt "\"%s\"" s)) eqlhs

385

(Location.loc_line l)

386


387

let fold_mutate_int i =

388

if Random.int 100 > threshold_inc_int then

389

i+1

390

else if Random.int 100 > threshold_dec_int then

391

i1

392

else if Random.int 100 > threshold_random_int then

393

Random.int 10

394

else if Random.int 100 > threshold_switch_int then

395

try

396

let idx = Random.int (List.length !int_consts) in

397

List.nth !int_consts idx

398

with _ > i

399

else

400

i

401


402

let fold_mutate_float f =

403

if Random.int 100 > threshold_random_float then

404

Random.float 10.

405

else

406

f

407


408

let fold_mutate_op op =

409

(* match op with *)

410

(*  "+"  ""  "*"  "/" when Random.int 100 > threshold_arith_op > *)

411

(* let filtered = List.filter (fun x > x <> op) ["+"; ""; "*"; "/"] in *)

412

(* List.nth filtered (Random.int 3) *)

413

(*  "&&"  ""  "xor"  "impl" when Random.int 100 > threshold_bool_op > *)

414

(* let filtered = List.filter (fun x > x <> op) ["&&"; ""; "xor"; "impl"] in *)

415

(* List.nth filtered (Random.int 3) *)

416

(*  "<"  "<="  ">"  ">="  "!="  "=" when Random.int 100 > threshold_rel_op > *)

417

(* let filtered = List.filter (fun x > x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)

418

(* List.nth filtered (Random.int 5) *)

419

(*  _ > op *)

420

match !target with

421

 Some (Op(op_orig, 0, op_new)) when op_orig = op > (

422

set_mutation_loc ();

423

op_new

424

)

425

 Some (Op(op_orig, n, op_new)) when op_orig = op > (

426

target := Some (Op(op_orig, n1, op_new));

427

op

428

)

429

 _ > if List.mem op Basic_library.internal_funs then op else rename_app op

430


431


432

let fold_mutate_var expr =

433

(* match (Types.repr expr.expr_type).Types.tdesc with *)

434

(*  Types.Tbool > *)

435

(* (\* if Random.int 100 > threshold_negate_bool_var then *\) *)

436

(* mkpredef_unary_call Location.dummy_loc "not" expr *)

437

(* (\* else *\) *)

438

(* (\* expr *\) *)

439

(*  _ >

440

*)expr

441


442

let fold_mutate_boolexpr expr =

443

match !target with

444

 Some (Boolexpr 0) > (

445

set_mutation_loc ();

446


447

mkpredef_call expr.expr_loc "not" [expr]

448

)

449

 Some (Boolexpr n) >

450

(target := Some (Boolexpr (n1)); expr)

451

 _ > expr

452


453

let fold_mutate_pre orig_expr e =

454

match !target with

455

Some (Pre 0) > (

456

set_mutation_loc ();

457

Expr_pre ({orig_expr with expr_desc = Expr_pre e})

458

)

459

 Some (Pre n) > (

460

target := Some (Pre (n1));

461

Expr_pre e

462

)

463

 _ > Expr_pre e

464


465

let fold_mutate_const_value c =

466

match c with

467

 Const_int i > (

468

match !target with

469

 Some (IncrIntCst 0) > (set_mutation_loc (); Const_int (i+1))

470

 Some (DecrIntCst 0) > (set_mutation_loc (); Const_int (i1))

471

 Some (SwitchIntCst (0, id)) > (set_mutation_loc (); Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id))

472

 Some (IncrIntCst n) > (target := Some (IncrIntCst (n1)); c)

473

 Some (DecrIntCst n) > (target := Some (DecrIntCst (n1)); c)

474

 Some (SwitchIntCst (n, id)) > (target := Some (SwitchIntCst (n1, id)); c)

475

 _ > c)

476

 _ > c

477


478

(*

479

match c with

480

 Const_int i > Const_int (fold_mutate_int i)

481

 Const_real s > Const_real s (* those are string, let's leave them *)

482

 Const_float f > Const_float (fold_mutate_float f)

483

 Const_array _

484

 Const_tag _ > c

485

TODO

486


487

*)

488

let fold_mutate_const c =

489

{ c with const_value = fold_mutate_const_value c.const_value }

490


491

let rec fold_mutate_expr expr =

492

current_loc := Some expr.expr_loc;

493

let new_expr =

494

match expr.expr_desc with

495

 Expr_ident id > fold_mutate_var expr

496

 _ > (

497

let new_desc = match expr.expr_desc with

498

 Expr_const c > Expr_const (fold_mutate_const_value c)

499

 Expr_tuple l > Expr_tuple (List.fold_right (fun e res > (fold_mutate_expr e)::res) l [])

500

 Expr_ite (i,t,e) > Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)

501

 Expr_arrow (e1, e2) > Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)

502

 Expr_pre e > fold_mutate_pre expr (fold_mutate_expr e)

503

 Expr_appl (op_id, args, r) > Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)

504

(* Other constructs are kept.

505

 Expr_fby of expr * expr

506

 Expr_array of expr list

507

 Expr_access of expr * Dimension.dim_expr

508

 Expr_power of expr * Dimension.dim_expr

509

 Expr_when of expr * ident * label

510

 Expr_merge of ident * (label * expr) list

511

 Expr_uclock of expr * int

512

 Expr_dclock of expr * int

513

 Expr_phclock of expr * rat *)

514

 _ > expr.expr_desc

515


516

in

517

{ expr with expr_desc = new_desc }

518

)

519

in

520

if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then

521

fold_mutate_boolexpr new_expr

522

else

523

new_expr

524


525

let fold_mutate_eq eq =

526

current_eq_lhs := Some eq.eq_lhs;

527

{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }

528


529

let fold_mutate_stmt stmt =

530

match stmt with

531

 Eq eq > Eq (fold_mutate_eq eq)

532

 Aut aut > assert false

533


534

let fold_mutate_node nd =

535

current_node := Some nd.node_id;

536

{ nd with

537

node_stmts =

538

List.fold_right (fun stmt res > (fold_mutate_stmt stmt)::res) nd.node_stmts [];

539

node_id = rename_app nd.node_id

540

}

541


542

let fold_mutate_top_decl td =

543

match td.top_decl_desc with

544

 Node nd > { td with top_decl_desc = Node (fold_mutate_node nd)}

545

 Const cst > { td with top_decl_desc = Const (fold_mutate_const cst)}

546

 _ > td

547


548

(* Create a single mutant with the provided random seed *)

549

let fold_mutate_prog prog =

550

List.fold_right (fun e res > (fold_mutate_top_decl e)::res) prog []

551


552

let create_mutant prog directive =

553

target := Some directive;

554

let prog' = fold_mutate_prog prog in

555

let mutation_info = match !target , !mutation_info with

556

 None, Some mi > mi

557

 _ > assert false (* The mutation has not been performed. *)

558


559

in

560

(* target := None; (* should happen only if no mutation occured during the

561

visit *)*)

562

prog', mutation_info

563


564


565

let op_mutation op =

566

let res =

567

let rem_op l = List.filter (fun e > e <> op) l in

568

if List.mem op arith_op then rem_op arith_op else

569

if List.mem op bool_op then rem_op bool_op else

570

if List.mem op rel_op then rem_op rel_op else

571

(Format.eprintf "Failing with op %s@." op;

572

assert false

573

)

574

in

575

(* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)

576

res

577


578

let rec remains select list =

579

match list with

580

[] > []

581

 hd::tl > if select hd then tl else remains select tl

582


583

let next_change m =

584

let res =

585

let rec first_op () =

586

try

587

let min_binding = OpCount.min_binding !records.nb_op in

588

Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))

589

with Not_found > first_boolexpr ()

590

and first_boolexpr () =

591

if !records.nb_boolexpr > 0 then

592

Boolexpr 0

593

else first_pre ()

594

and first_pre () =

595

if !records.nb_pre > 0 then

596

Pre 0

597

else

598

first_op ()

599

and first_intcst () =

600

if IntSet.cardinal !records.consts > 0 then

601

IncrIntCst 0

602

else

603

first_boolexpr ()

604

in

605

match m with

606

 Boolexpr n >

607

if n+1 >= !records.nb_boolexpr then

608

first_pre ()

609

else

610

Boolexpr (n+1)

611

 Pre n >

612

if n+1 >= !records.nb_pre then

613

first_op ()

614

else Pre (n+1)

615

 Op (orig, id, mut_op) > (

616

match remains (fun x > x = mut_op) (op_mutation orig) with

617

 next_op::_ > Op (orig, id, next_op)

618

 [] > if id+1 >= OpCount.find orig !records.nb_op then (

619

match remains (fun (k1, _) > k1 = orig) (OpCount.bindings !records.nb_op) with

620

 [] > first_intcst ()

621

 hd::_ > Op (fst hd, 0, List.hd (op_mutation (fst hd)))

622

) else

623

Op(orig, id+1, List.hd (op_mutation orig))

624

)

625

 IncrIntCst n >

626

if n+1 >= IntSet.cardinal !records.consts then

627

DecrIntCst 0

628

else IncrIntCst (n+1)

629

 DecrIntCst n >

630

if n+1 >= IntSet.cardinal !records.consts then

631

SwitchIntCst (0, 0)

632

else DecrIntCst (n+1)

633

 SwitchIntCst (n, m) >

634

if m+1 > 1 + IntSet.cardinal !records.consts then

635

SwitchIntCst (n, m+1)

636

else if n+1 >= IntSet.cardinal !records.consts then

637

SwitchIntCst (n+1, 0)

638

else first_boolexpr ()

639


640

in

641

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

642

res

643


644

let fold_mutate nb prog =

645

incr random_seed;

646

Random.init !random_seed;

647

let find_next_new mutants mutant =

648

let rec find_next_new init current =

649

if init = current then raise Not_found else

650

if List.mem current mutants then

651

find_next_new init (next_change current)

652

else

653

current

654

in

655

find_next_new mutant (next_change mutant)

656

in

657

(* Creating list of nb elements of mutants *)

658

let rec create_mutants_directives rnb mutants =

659

if rnb <= 0 then mutants

660

else

661

let random_mutation =

662

match Random.int 6 with

663

 5 > IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ > 0)

664

 4 > DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ > 0)

665

 3 > SwitchIntCst ((try Random.int (IntSet.cardinal !records.consts) with _ > 0), (try Random.int (1 + IntSet.cardinal !records.consts) with _ > 0))

666

 2 > Pre (try Random.int !records.nb_pre with _ > 0)

667

 1 > Boolexpr (try Random.int !records.nb_boolexpr with _ > 0)

668

 0 > let bindings = OpCount.bindings !records.nb_op in

669

let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ > 0) in

670

let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ > 0) in

671

Op (op, (try Random.int nb_op with _ > 0), new_op)

672

 _ > assert false

673

in

674

if List.mem random_mutation mutants then

675

try

676

let new_mutant = (find_next_new mutants random_mutation) in

677

report ~level:2 (fun fmt > fprintf fmt " %i mutants generated out of %i expected@." (nbrnb) nb);

678

create_mutants_directives (rnb1) (new_mutant::mutants)

679

with Not_found > (

680

report ~level:1 (fun fmt > fprintf fmt "Only %i mutants generated out of %i expected@." (nbrnb) nb);

681

mutants

682

)

683

else

684

create_mutants_directives (rnb1) (random_mutation::mutants)

685

in

686

let mutants_directives = create_mutants_directives nb [] in

687

List.map (fun d >

688

let mutant, loc = create_mutant prog d in

689

d, loc, mutant ) mutants_directives

690


691


692

let mutate nb prog =

693

records := compute_records prog;

694

(* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)

695

(* !records.nb_pre *)

696

(* !records.nb_boolexpr *)

697

(* (\* !records.op *\) *)

698

(* ; *)

699

fold_mutate nb prog

700


701


702


703


704

(* Local Variables: *)

705

(* compilecommand:"make C .." *)

706

(* End: *)

707


708

