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

let eqs, auts = get_node_eqs nd in

108

assert (auts=[]); (* Automaton should be expanded by now *)

109

merge_records (List.map compute_records_eq eqs)

110


111

let compute_records_top_decl td =

112

match td.top_decl_desc with

113

 Node nd > compute_records_node nd

114

 Const cst > compute_records_const_value cst.const_value

115

 _ > empty_records

116


117

let compute_records prog =

118

merge_records (List.map compute_records_top_decl prog)

119


120

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

121

(* Random mutation *)

122

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

123


124

let check_mut e1 e2 =

125

let rec eq e1 e2 =

126

match e1.expr_desc, e2.expr_desc with

127

 Expr_const c1, Expr_const c2 > c1 = c2

128

 Expr_ident id1, Expr_ident id2 > id1 = id2

129

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

130

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

131

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

132

 Expr_pre e1, Expr_pre e2 > eq e1 e2

133

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

134

 _ > false

135

in

136

if not (eq e1 e2) then

137

Some (e1, e2)

138

else

139

None

140


141

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

142


143

let rdm_mutate_int i =

144

if Random.int 100 > threshold_inc_int then

145

i+1

146

else if Random.int 100 > threshold_dec_int then

147

i1

148

else if Random.int 100 > threshold_random_int then

149

Random.int 10

150

else if Random.int 100 > threshold_switch_int then

151

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

152

List.nth !int_consts idx

153

else

154

i

155


156

let rdm_mutate_real r =

157

if Random.int 100 > threshold_random_float then

158

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

159

let bound = 10 in

160

(* max number of digits after comma *)

161

let digits = 5 in

162

(* number of digits after comma *)

163

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

164

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

165

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

166

let f = float_of_int i /. eshift in

167

(Num.num_of_int i, shift, string_of_float f)

168

else

169

r

170


171

let rdm_mutate_op op =

172

match op with

173

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

174

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

175

List.nth filtered (Random.int 3)

176

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

177

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

178

List.nth filtered (Random.int 3)

179

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

180

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

181

List.nth filtered (Random.int 5)

182

 _ > op

183


184


185

let rdm_mutate_var expr =

186

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

187

 Types.Tbool >

188

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

189

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

190

Some (expr, new_e), new_e

191

(* else *)

192

(* expr *)

193

 _ > None, expr

194


195

let rdm_mutate_pre orig_expr =

196

let new_e = Expr_pre orig_expr in

197

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

198


199


200

let rdm_mutate_const_value c =

201

match c with

202

 Const_int i > Const_int (rdm_mutate_int i)

203

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

204

 Const_array _

205

 Const_string _

206

 Const_struct _

207

 Const_tag _ > c

208


209

let rdm_mutate_const c =

210

let new_const = rdm_mutate_const_value c.const_value in

211

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

212

mut, { c with const_value = new_const }

213


214


215

let select_in_list list rdm_mutate_elem =

216

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

217

let mutation_opt, new_list, _ =

218

List.fold_right

219

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

220

let mutation, new_elem = rdm_mutate_elem elem in

221

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

222

list

223

(None, [], 0)

224

in

225

match mutation_opt with

226

 Some mut > mut, new_list

227

 _ > assert false

228


229


230

let rec rdm_mutate_expr expr =

231

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

232

match expr.expr_desc with

233

 Expr_ident id > rdm_mutate_var expr

234

 Expr_const c >

235

let new_const = rdm_mutate_const_value c in

236

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

237

mut, mk_e (Expr_const new_const)

238

 Expr_tuple l >

239

let mut, l' = select_in_list l rdm_mutate_expr in

240

mut, mk_e (Expr_tuple l')

241

 Expr_ite (i,t,e) > (

242

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

243

match l with

244

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

245

 _ > assert false

246

)

247

 Expr_arrow (e1, e2) > (

248

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

249

match l with

250

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

251

 _ > assert false

252

)

253

 Expr_pre e >

254

let select_pre = Random.bool () in

255

if select_pre then

256

let mut, new_expr = rdm_mutate_pre expr in

257

mut, mk_e new_expr

258

else

259

let mut, e' = rdm_mutate_expr e in

260

mut, mk_e (Expr_pre e')

261

 Expr_appl (op_id, args, r) >

262

let select_op = Random.bool () in

263

if select_op then

264

let new_op_id = rdm_mutate_op op_id in

265

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

266

let mut = check_mut expr new_e in

267

mut, new_e

268

else

269

let mut, new_args = rdm_mutate_expr args in

270

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

271

(* Other constructs are kept.

272

 Expr_fby of expr * expr

273

 Expr_array of expr list

274

 Expr_access of expr * Dimension.dim_expr

275

 Expr_power of expr * Dimension.dim_expr

276

 Expr_when of expr * ident * label

277

 Expr_merge of ident * (label * expr) list

278

 Expr_uclock of expr * int

279

 Expr_dclock of expr * int

280

 Expr_phclock of expr * rat *)

281

 _ > None, expr

282


283


284

let rdm_mutate_eq eq =

285

let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in

286

mutation, { eq with eq_rhs = new_rhs }

287


288

let rnd_mutate_stmt stmt =

289

match stmt with

290

 Eq eq > let mut, new_eq = rdm_mutate_eq eq in

291

report ~level:1

292

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

293

Printers.pp_node_eq eq

294

Printers.pp_node_eq new_eq);

295

mut, Eq new_eq

296

 Aut aut > assert false

297


298

let rdm_mutate_node nd =

299

let mutation, new_node_stmts =

300

select_in_list

301

nd.node_stmts rnd_mutate_stmt

302

in

303

mutation, { nd with node_stmts = new_node_stmts }

304


305

let rdm_mutate_top_decl td =

306

match td.top_decl_desc with

307

 Node nd >

308

let mutation, new_node = rdm_mutate_node nd in

309

mutation, { td with top_decl_desc = Node new_node}

310

 Const cst >

311

let mut, new_cst = rdm_mutate_const cst in

312

mut, { td with top_decl_desc = Const new_cst }

313

 _ > None, td

314


315

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

316

let rdm_mutate_prog prog =

317

select_in_list prog rdm_mutate_top_decl

318


319

let rdm_mutate nb prog =

320

let rec iterate nb res =

321

incr random_seed;

322

if nb <= 0 then

323

res

324

else (

325

Random.init !random_seed;

326

let mutation, new_mutant = rdm_mutate_prog prog in

327

match mutation with

328

None > iterate nb res

329

 Some mutation > (

330

if List.mem_assoc mutation res then (

331

iterate nb res

332

)

333

else (

334

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

335

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

336

)

337

)

338

)

339

in

340

iterate nb []

341


342


343

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

344

(* Random mutation *)

345

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

346


347

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

348


349

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

350

type mutation_loc = ident * ident list * Location.t

351

let target : mutant_t option ref = ref None

352


353

let mutation_info : mutation_loc option ref = ref None

354

let current_node: ident option ref = ref None

355

let current_eq_lhs : ident list option ref = ref None

356

let current_loc : Location.t option ref = ref None

357


358

let set_mutation_loc () =

359

target := None;

360

match !current_node, !current_eq_lhs, !current_loc with

361

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

362

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

363

visitor pattern execution *)

364


365

let print_directive fmt d =

366

match d with

367

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

368

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

369

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

370

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

371

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

372

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

373


374

let print_directive_json fmt d =

375

match d with

376

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

377

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

378

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

379

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

380

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

381

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

382


383

let print_loc_json fmt (n,eqlhs, l) =

384

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

385

n

386

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

387

(Location.loc_line l)

388


389

let fold_mutate_int i =

390

if Random.int 100 > threshold_inc_int then

391

i+1

392

else if Random.int 100 > threshold_dec_int then

393

i1

394

else if Random.int 100 > threshold_random_int then

395

Random.int 10

396

else if Random.int 100 > threshold_switch_int then

397

try

398

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

399

List.nth !int_consts idx

400

with _ > i

401

else

402

i

403


404

let fold_mutate_float f =

405

if Random.int 100 > threshold_random_float then

406

Random.float 10.

407

else

408

f

409


410

let fold_mutate_op op =

411

(* match op with *)

412

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

413

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

414

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

415

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

416

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

417

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

418

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

419

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

420

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

421

(*  _ > op *)

422

match !target with

423

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

424

set_mutation_loc ();

425

op_new

426

)

427

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

428

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

429

op

430

)

431

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

432


433


434

let fold_mutate_var expr =

435

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

436

(*  Types.Tbool > *)

437

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

438

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

439

(* (\* else *\) *)

440

(* (\* expr *\) *)

441

(*  _ >

442

*)expr

443


444

let fold_mutate_boolexpr expr =

445

match !target with

446

 Some (Boolexpr 0) > (

447

set_mutation_loc ();

448


449

mkpredef_call expr.expr_loc "not" [expr]

450

)

451

 Some (Boolexpr n) >

452

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

453

 _ > expr

454


455

let fold_mutate_pre orig_expr e =

456

match !target with

457

Some (Pre 0) > (

458

set_mutation_loc ();

459

Expr_pre ({orig_expr with expr_desc = Expr_pre e})

460

)

461

 Some (Pre n) > (

462

target := Some (Pre (n1));

463

Expr_pre e

464

)

465

 _ > Expr_pre e

466


467

let fold_mutate_const_value c =

468

match c with

469

 Const_int i > (

470

match !target with

471

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

472

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

473

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

474

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

475

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

476

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

477

 _ > c)

478

 _ > c

479


480

(*

481

match c with

482

 Const_int i > Const_int (fold_mutate_int i)

483

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

484

 Const_float f > Const_float (fold_mutate_float f)

485

 Const_array _

486

 Const_tag _ > c

487

TODO

488


489

*)

490

let fold_mutate_const c =

491

{ c with const_value = fold_mutate_const_value c.const_value }

492


493

let rec fold_mutate_expr expr =

494

current_loc := Some expr.expr_loc;

495

let new_expr =

496

match expr.expr_desc with

497

 Expr_ident id > fold_mutate_var expr

498

 _ > (

499

let new_desc = match expr.expr_desc with

500

 Expr_const c > Expr_const (fold_mutate_const_value c)

501

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

502

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

503

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

504

 Expr_pre e > fold_mutate_pre expr (fold_mutate_expr e)

505

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

506

(* Other constructs are kept.

507

 Expr_fby of expr * expr

508

 Expr_array of expr list

509

 Expr_access of expr * Dimension.dim_expr

510

 Expr_power of expr * Dimension.dim_expr

511

 Expr_when of expr * ident * label

512

 Expr_merge of ident * (label * expr) list

513

 Expr_uclock of expr * int

514

 Expr_dclock of expr * int

515

 Expr_phclock of expr * rat *)

516

 _ > expr.expr_desc

517


518

in

519

{ expr with expr_desc = new_desc }

520

)

521

in

522

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

523

fold_mutate_boolexpr new_expr

524

else

525

new_expr

526


527

let fold_mutate_eq eq =

528

current_eq_lhs := Some eq.eq_lhs;

529

{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }

530


531

let fold_mutate_stmt stmt =

532

match stmt with

533

 Eq eq > Eq (fold_mutate_eq eq)

534

 Aut aut > assert false

535


536

let fold_mutate_node nd =

537

current_node := Some nd.node_id;

538

{ nd with

539

node_stmts =

540

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

541

node_id = rename_app nd.node_id

542

}

543


544

let fold_mutate_top_decl td =

545

match td.top_decl_desc with

546

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

547

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

548

 _ > td

549


550

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

551

let fold_mutate_prog prog =

552

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

553


554

let create_mutant prog directive =

555

target := Some directive;

556

let prog' = fold_mutate_prog prog in

557

let mutation_info = match !target , !mutation_info with

558

 None, Some mi > mi

559

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

560


561

in

562

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

563

visit *)*)

564

prog', mutation_info

565


566


567

let op_mutation op =

568

let res =

569

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

570

if List.mem op arith_op then rem_op arith_op else

571

if List.mem op bool_op then rem_op bool_op else

572

if List.mem op rel_op then rem_op rel_op else

573

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

574

assert false

575

)

576

in

577

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

578

res

579


580

let rec remains select list =

581

match list with

582

[] > []

583

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

584


585

let next_change m =

586

let res =

587

let rec first_op () =

588

try

589

let min_binding = OpCount.min_binding !records.nb_op in

590

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

591

with Not_found > first_boolexpr ()

592

and first_boolexpr () =

593

if !records.nb_boolexpr > 0 then

594

Boolexpr 0

595

else first_pre ()

596

and first_pre () =

597

if !records.nb_pre > 0 then

598

Pre 0

599

else

600

first_op ()

601

and first_intcst () =

602

if IntSet.cardinal !records.consts > 0 then

603

IncrIntCst 0

604

else

605

first_boolexpr ()

606

in

607

match m with

608

 Boolexpr n >

609

if n+1 >= !records.nb_boolexpr then

610

first_pre ()

611

else

612

Boolexpr (n+1)

613

 Pre n >

614

if n+1 >= !records.nb_pre then

615

first_op ()

616

else Pre (n+1)

617

 Op (orig, id, mut_op) > (

618

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

619

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

620

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

621

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

622

 [] > first_intcst ()

623

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

624

) else

625

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

626

)

627

 IncrIntCst n >

628

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

629

DecrIntCst 0

630

else IncrIntCst (n+1)

631

 DecrIntCst n >

632

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

633

SwitchIntCst (0, 0)

634

else DecrIntCst (n+1)

635

 SwitchIntCst (n, m) >

636

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

637

SwitchIntCst (n, m+1)

638

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

639

SwitchIntCst (n+1, 0)

640

else first_boolexpr ()

641


642

in

643

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

644

res

645


646

let fold_mutate nb prog =

647

incr random_seed;

648

Random.init !random_seed;

649

let find_next_new mutants mutant =

650

let rec find_next_new init current =

651

if init = current then raise Not_found else

652

if List.mem current mutants then

653

find_next_new init (next_change current)

654

else

655

current

656

in

657

find_next_new mutant (next_change mutant)

658

in

659

(* Creating list of nb elements of mutants *)

660

let rec create_mutants_directives rnb mutants =

661

if rnb <= 0 then mutants

662

else

663

let random_mutation =

664

match Random.int 6 with

665

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

666

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

667

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

668

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

669

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

670

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

671

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

672

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

673

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

674

 _ > assert false

675

in

676

if List.mem random_mutation mutants then

677

try

678

let new_mutant = (find_next_new mutants random_mutation) in

679

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

680

create_mutants_directives (rnb1) (new_mutant::mutants)

681

with Not_found > (

682

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

683

mutants

684

)

685

else

686

create_mutants_directives (rnb1) (random_mutation::mutants)

687

in

688

let mutants_directives = create_mutants_directives nb [] in

689

List.map (fun d >

690

let mutant, loc = create_mutant prog d in

691

d, loc, mutant ) mutants_directives

692


693


694

let mutate nb prog =

695

records := compute_records prog;

696

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

697

(* !records.nb_pre *)

698

(* !records.nb_boolexpr *)

699

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

700

(* ; *)

701

fold_mutate nb prog

702


703


704


705


706

(* Local Variables: *)

707

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

708

(* End: *)

709


710

