1

(* Comments in function fold_mutate

2


3

TODO: check if we can generate more cases. The following lines were cylcing

4

and missing to detect that the enumaration was complete, leading to a non

5

terminating process. The current setting is harder but may miss enumerating

6

some cases. To be checked! *)

7


8

open Lustre_types

9

open Corelang

10

open Log

11

open Format

12


13

let random_seed = ref 0

14


15

let threshold_delay = 95

16


17

let threshold_inc_int = 97

18


19

let threshold_dec_int = 97

20


21

let threshold_random_int = 96

22


23

let threshold_switch_int = 100

24

(* not implemented yet *)

25


26

let threshold_random_float = 100

27

(* not used yet *)

28


29

let threshold_negate_bool_var = 95

30


31

let threshold_arith_op = 95

32


33

let threshold_rel_op = 95

34


35

let threshold_bool_op = 95

36


37

let int_consts = ref []

38


39

let rename_app id =

40

if List.mem id Basic_library.internal_funs  !Options.no_mutation_suffix then

41

id

42

else

43

let node = Corelang.node_from_name id in

44

let is_imported =

45

match node.top_decl_desc with ImportedNode _ > true  _ > false

46

in

47

if is_imported then id else id ^ "_mutant"

48


49

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

50

(* Gathering constants in the code *)

51

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

52


53

module IntSet = Set.Make (struct

54

type t = int

55


56

let compare = compare

57

end)

58


59

module OpCount = Mmap.Make (struct

60

type t = string

61


62

let compare = compare

63

end)

64


65

type records = {

66

consts : IntSet.t;

67

nb_consts : int;

68

nb_boolexpr : int;

69

nb_pre : int;

70

nb_op : int OpCount.t;

71

}

72


73

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

74


75

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

76


77

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

78


79

let ops = arith_op @ bool_op @ rel_op

80


81

let all_ops = "not" :: ops

82


83

let empty_records =

84

{

85

consts = IntSet.empty;

86

nb_consts = 0;

87

nb_boolexpr = 0;

88

nb_pre = 0;

89

nb_op = OpCount.empty;

90

}

91


92

let records = ref empty_records

93


94

let merge_records records_list =

95

let merge_record r1 r2 =

96

{

97

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

98

nb_consts = r1.nb_consts + r2.nb_consts;

99

nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;

100

nb_pre = r1.nb_pre + r2.nb_pre;

101

nb_op =

102

OpCount.merge

103

(fun _ r1opt r2opt >

104

match r1opt, r2opt with

105

 None, _ >

106

r2opt

107

 _, None >

108

r1opt

109

 Some x, Some y >

110

Some (x + y))

111

r1.nb_op r2.nb_op;

112

}

113

in

114

List.fold_left merge_record empty_records records_list

115


116

let compute_records_const_value c =

117

match c with

118

 Const_int i >

119

{ empty_records with consts = IntSet.singleton i; nb_consts = 1 }

120

 _ >

121

empty_records

122


123

let rec compute_records_expr expr =

124

let boolexpr =

125

if Types.is_bool_type expr.expr_type then

126

{ empty_records with nb_boolexpr = 1 }

127

else empty_records

128

in

129

let subrec =

130

match expr.expr_desc with

131

 Expr_const c >

132

compute_records_const_value c

133

 Expr_tuple l >

134

merge_records (List.map compute_records_expr l)

135

 Expr_ite (i, t, e) >

136

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

137

 Expr_arrow (e1, e2) >

138

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

139

 Expr_pre e >

140

merge_records

141

[ { empty_records with nb_pre = 1 }; compute_records_expr e ]

142

 Expr_appl (op_id, args, _) >

143

if List.mem op_id ops then

144

merge_records

145

[

146

{ empty_records with nb_op = OpCount.singleton op_id 1 };

147

compute_records_expr args;

148

]

149

else compute_records_expr args

150

 _ >

151

empty_records

152

in

153

merge_records [ boolexpr; subrec ]

154


155

let compute_records_eq eq = compute_records_expr eq.eq_rhs

156


157

let compute_records_node nd =

158

let eqs, auts = get_node_eqs nd in

159

assert (auts = []);

160

(* Automaton should be expanded by now *)

161

merge_records (List.map compute_records_eq eqs)

162


163

let compute_records_top_decl td =

164

match td.top_decl_desc with

165

 Node nd >

166

compute_records_node nd

167

 Const cst >

168

compute_records_const_value cst.const_value

169

 _ >

170

empty_records

171


172

let compute_records prog =

173

merge_records (List.map compute_records_top_decl prog)

174


175

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

176

(* Random mutation *)

177

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

178


179

let check_mut e1 e2 =

180

let rec eq e1 e2 =

181

match e1.expr_desc, e2.expr_desc with

182

 Expr_const c1, Expr_const c2 >

183

c1 = c2

184

 Expr_ident id1, Expr_ident id2 >

185

id1 = id2

186

 Expr_tuple el1, Expr_tuple el2 >

187

List.length el1 = List.length el2 && List.for_all2 eq el1 el2

188

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

189

eq i1 i2 && eq t1 t2 && eq e1 e2

190

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

191

eq x1 x2 && eq y1 y2

192

 Expr_pre e1, Expr_pre e2 >

193

eq e1 e2

194

 Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) >

195

id1 = id2 && eq e1 e2

196

 _ >

197

false

198

in

199

if not (eq e1 e2) then Some (e1, e2) else None

200


201

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

202


203

let rdm_mutate_int i =

204

if Random.int 100 > threshold_inc_int then i + 1

205

else if Random.int 100 > threshold_dec_int then i  1

206

else if Random.int 100 > threshold_random_int then Random.int 10

207

else if Random.int 100 > threshold_switch_int then

208

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

209

List.nth !int_consts idx

210

else i

211


212

let rdm_mutate_real r =

213

if Random.int 100 > threshold_random_float then

214

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

215

let bound = 10 in

216

(* max number of digits after comma *)

217

let digits = 5 in

218

(* number of digits after comma *)

219

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

220

let eshift = 10. ** float_of_int shift in

221

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

222

let f = float_of_int i /. eshift in

223

Real.create (string_of_int i) shift (string_of_float f)

224

else r

225


226

let rdm_mutate_op op =

227

match op with

228

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

229

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

230

List.nth filtered (Random.int 3)

231

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

232

let filtered =

233

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

234

in

235

List.nth filtered (Random.int 3)

236

 ("<"  "<="  ">"  ">="  "!="  "=")

237

when Random.int 100 > threshold_rel_op >

238

let filtered =

239

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

240

in

241

List.nth filtered (Random.int 5)

242

 _ >

243

op

244


245

let rdm_mutate_var expr =

246

if Types.is_bool_type expr.expr_type then

247

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

248

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

249

Some (expr, new_e), new_e

250

(* else *)

251

(* expr *)

252

else None, expr

253


254

let rdm_mutate_pre orig_expr =

255

let new_e = Expr_pre orig_expr in

256

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

257


258

let rdm_mutate_const_value c =

259

match c with

260

 Const_int i >

261

Const_int (rdm_mutate_int i)

262

 Const_real r >

263

Const_real (rdm_mutate_real r)

264

 Const_array _

265

 Const_string _

266

 Const_modeid _

267

 Const_struct _

268

 Const_tag _ >

269

c

270


271

let rdm_mutate_const c =

272

let new_const = rdm_mutate_const_value c.const_value in

273

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

274

mut, { c with const_value = new_const }

275


276

let select_in_list list rdm_mutate_elem =

277

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

278

let mutation_opt, new_list, _ =

279

List.fold_right

280

(fun elem (mutation_opt, res, cpt) >

281

if cpt = selected then

282

let mutation, new_elem = rdm_mutate_elem elem in

283

Some mutation, new_elem :: res, cpt + 1

284

else mutation_opt, elem :: res, cpt + 1)

285

list (None, [], 0)

286

in

287

match mutation_opt with Some mut > mut, new_list  _ > assert false

288


289

let rec rdm_mutate_expr expr =

290

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

291

match expr.expr_desc with

292

 Expr_ident _ >

293

rdm_mutate_var expr

294

 Expr_const c >

295

let new_const = rdm_mutate_const_value c in

296

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

297

mut, mk_e (Expr_const new_const)

298

 Expr_tuple l >

299

let mut, l' = select_in_list l rdm_mutate_expr in

300

mut, mk_e (Expr_tuple l')

301

 Expr_ite (i, t, e) > (

302

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

303

match l with

304

 [ i'; t'; e' ] >

305

mut, mk_e (Expr_ite (i', t', e'))

306

 _ >

307

assert false)

308

 Expr_arrow (e1, e2) > (

309

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

310

match l with

311

 [ e1'; e2' ] >

312

mut, mk_e (Expr_arrow (e1', e2'))

313

 _ >

314

assert false)

315

 Expr_pre e >

316

let select_pre = Random.bool () in

317

if select_pre then

318

let mut, new_expr = rdm_mutate_pre expr in

319

mut, mk_e new_expr

320

else

321

let mut, e' = rdm_mutate_expr e in

322

mut, mk_e (Expr_pre e')

323

 Expr_appl (op_id, args, r) >

324

let select_op = Random.bool () in

325

if select_op then

326

let new_op_id = rdm_mutate_op op_id in

327

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

328

let mut = check_mut expr new_e in

329

mut, new_e

330

else

331

let mut, new_args = rdm_mutate_expr args in

332

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

333

(* Other constructs are kept.  Expr_fby of expr * expr  Expr_array of expr

334

list  Expr_access of expr * Dimension.dim_expr  Expr_power of expr *

335

Dimension.dim_expr  Expr_when of expr * ident * label  Expr_merge of

336

ident * (label * expr) list  Expr_uclock of expr * int  Expr_dclock of

337

expr * int  Expr_phclock of expr * rat *)

338

 _ >

339

None, expr

340


341

let rdm_mutate_eq eq =

342

let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in

343

mutation, { eq with eq_rhs = new_rhs }

344


345

let rnd_mutate_stmt stmt =

346

match stmt with

347

 Eq eq >

348

let mut, new_eq = rdm_mutate_eq eq in

349

report ~level:1 (fun fmt >

350

fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq

351

Printers.pp_node_eq new_eq);

352

mut, Eq new_eq

353

 Aut _ >

354

assert false

355


356

let rdm_mutate_node nd =

357

let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in

358

mutation, { nd with node_stmts = new_node_stmts }

359


360

let rdm_mutate_top_decl td =

361

match td.top_decl_desc with

362

 Node nd >

363

let mutation, new_node = rdm_mutate_node nd in

364

mutation, { td with top_decl_desc = Node new_node }

365

 Const cst >

366

let mut, new_cst = rdm_mutate_const cst in

367

mut, { td with top_decl_desc = Const new_cst }

368

 _ >

369

None, td

370


371

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

372

let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl

373


374

let rdm_mutate nb prog =

375

let rec iterate nb res =

376

incr random_seed;

377

if nb <= 0 then res

378

else (

379

Random.init !random_seed;

380

let mutation, new_mutant = rdm_mutate_prog prog in

381

match mutation with

382

 None >

383

iterate nb res

384

 Some mutation >

385

if List.mem_assoc mutation res then iterate nb res

386

else (

387

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

388

iterate (nb  1) ((mutation, new_mutant) :: res)))

389

in

390

iterate nb []

391


392

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

393

(* Random mutation *)

394

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

395


396

type mutant_t =

397

 Boolexpr of int

398

 Pre of int

399

 Op of string * int * string

400

 IncrIntCst of int

401

 DecrIntCst of int

402

 SwitchIntCst of int * int

403


404

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

405

type mutation_loc = ident * ident list * Location.t

406


407

let target : mutant_t option ref = ref None

408


409

let mutation_info : mutation_loc option ref = ref None

410


411

let current_node : ident option ref = ref None

412


413

let current_eq_lhs : ident list option ref = ref None

414


415

let current_loc : Location.t option ref = ref None

416


417

let set_mutation_loc () =

418

target := None;

419

match !current_node, !current_eq_lhs, !current_loc with

420

 Some n, Some elhs, Some l >

421

mutation_info := Some (n, elhs, l)

422

 _ >

423

assert false

424

(* Those global vars should be defined during the visitor pattern execution *)

425


426

let print_directive fmt d =

427

match d with

428

 Pre n >

429

Format.fprintf fmt "pre %i" n

430

 Boolexpr n >

431

Format.fprintf fmt "boolexpr %i" n

432

 Op (o, i, d) >

433

Format.fprintf fmt "%s %i > %s" o i d

434

 IncrIntCst n >

435

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

436

 DecrIntCst n >

437

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

438

 SwitchIntCst (n, m) >

439

Format.fprintf fmt "switch int cst %i > %i" n m

440


441

let print_directive_json fmt d =

442

match d with

443

 Pre _ >

444

Format.fprintf fmt "\"mutation\": \"pre\""

445

 Boolexpr _ >

446

Format.fprintf fmt "\"mutation\": \"not\""

447

 Op (o, _, d) >

448

Format.fprintf fmt

449

"\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d

450

 IncrIntCst _ >

451

Format.fprintf fmt "\"mutation\": \"cst_incr\""

452

 DecrIntCst _ >

453

Format.fprintf fmt "\"mutation\": \"cst_decr\""

454

 SwitchIntCst (_, m) >

455

Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m

456


457

let print_loc_json fmt (n, eqlhs, l) =

458

Format.fprintf fmt

459

"\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" n

460

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

461

eqlhs (Location.loc_line l)

462


463

let fold_mutate_int i =

464

if Random.int 100 > threshold_inc_int then i + 1

465

else if Random.int 100 > threshold_dec_int then i  1

466

else if Random.int 100 > threshold_random_int then Random.int 10

467

else if Random.int 100 > threshold_switch_int then

468

try

469

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

470

List.nth !int_consts idx

471

with _ > i

472

else i

473


474

let fold_mutate_float f =

475

if Random.int 100 > threshold_random_float then Random.float 10. else f

476


477

let fold_mutate_op op =

478

(* match op with *)

479

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

480

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

481

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

482

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

483

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

484

in *)

485

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

486

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

487

threshold_rel_op > *)

488

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

489

"="] in *)

490

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

491

(*  _ > op *)

492

match !target with

493

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

494

set_mutation_loc ();

495

op_new

496

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

497

target := Some (Op (op_orig, n  1, op_new));

498

op

499

 _ >

500

op

501


502

let fold_mutate_var expr =

503

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

504

(*  Types.Tbool > *)

505

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

506

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

507

(* (\* else *\) *)

508

(* (\* expr *\) *)

509

(*  _ > *)

510

expr

511


512

let fold_mutate_boolexpr expr =

513

match !target with

514

 Some (Boolexpr 0) >

515

set_mutation_loc ();

516


517

mkpredef_call expr.expr_loc "not" [ expr ]

518

 Some (Boolexpr n) >

519

target := Some (Boolexpr (n  1));

520

expr

521

 _ >

522

expr

523


524

let fold_mutate_pre orig_expr e =

525

match !target with

526

 Some (Pre 0) >

527

set_mutation_loc ();

528

Expr_pre { orig_expr with expr_desc = Expr_pre e }

529

 Some (Pre n) >

530

target := Some (Pre (n  1));

531

Expr_pre e

532

 _ >

533

Expr_pre e

534


535

let fold_mutate_const_value c =

536

match c with

537

 Const_int i > (

538

match !target with

539

 Some (IncrIntCst 0) >

540

set_mutation_loc ();

541

Const_int (i + 1)

542

 Some (DecrIntCst 0) >

543

set_mutation_loc ();

544

Const_int (i  1)

545

 Some (SwitchIntCst (0, id)) >

546

set_mutation_loc ();

547

Const_int id

548

 Some (IncrIntCst n) >

549

target := Some (IncrIntCst (n  1));

550

c

551

 Some (DecrIntCst n) >

552

target := Some (DecrIntCst (n  1));

553

c

554

 Some (SwitchIntCst (n, id)) >

555

target := Some (SwitchIntCst (n  1, id));

556

c

557

 _ >

558

c)

559

 _ >

560

c

561


562

(* match c with  Const_int i > Const_int (fold_mutate_int i)  Const_real s >

563

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

564

Const_float (fold_mutate_float f)  Const_array _  Const_tag _ > c TODO *)

565

let fold_mutate_const c =

566

{ c with const_value = fold_mutate_const_value c.const_value }

567


568

let rec fold_mutate_expr expr =

569

current_loc := Some expr.expr_loc;

570

let new_expr =

571

match expr.expr_desc with

572

 Expr_ident _ >

573

fold_mutate_var expr

574

 _ >

575

let new_desc =

576

match expr.expr_desc with

577

 Expr_const c >

578

Expr_const (fold_mutate_const_value c)

579

 Expr_tuple l >

580

Expr_tuple

581

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

582

 Expr_ite (i, t, e) >

583

Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)

584

 Expr_arrow (e1, e2) >

585

Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)

586

 Expr_pre e >

587

fold_mutate_pre expr (fold_mutate_expr e)

588

 Expr_appl (op_id, args, r) >

589

Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)

590

(* Other constructs are kept.  Expr_fby of expr * expr  Expr_array of

591

expr list  Expr_access of expr * Dimension.dim_expr  Expr_power of

592

expr * Dimension.dim_expr  Expr_when of expr * ident * label 

593

Expr_merge of ident * (label * expr) list  Expr_uclock of expr * int

594

 Expr_dclock of expr * int  Expr_phclock of expr * rat *)

595

 _ >

596

expr.expr_desc

597

in

598


599

{ expr with expr_desc = new_desc }

600

in

601

if Types.is_bool_type expr.expr_type then fold_mutate_boolexpr new_expr

602

else new_expr

603


604

let fold_mutate_eq eq =

605

current_eq_lhs := Some eq.eq_lhs;

606

{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }

607


608

let fold_mutate_stmt stmt =

609

match stmt with Eq eq > Eq (fold_mutate_eq eq)  Aut _ > assert false

610


611

let fold_mutate_node nd =

612

current_node := Some nd.node_id;

613

let nd =

614

{

615

nd with

616

node_stmts =

617

List.fold_right

618

(fun stmt res > fold_mutate_stmt stmt :: res)

619

nd.node_stmts [];

620

}

621

in

622

rename_node rename_app (fun x > x) nd

623


624

let fold_mutate_top_decl td =

625

match td.top_decl_desc with

626

 Node nd >

627

{ td with top_decl_desc = Node (fold_mutate_node nd) }

628

 Const cst >

629

{ td with top_decl_desc = Const (fold_mutate_const cst) }

630

 _ >

631

td

632


633

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

634

let fold_mutate_prog prog =

635

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

636


637

let create_mutant prog directive =

638

target := Some directive;

639

let prog' = fold_mutate_prog prog in

640

let mutation_info =

641

match !target, !mutation_info with

642

 None, Some mi >

643

mi

644

 _ >

645

Format.eprintf "Failed when creating mutant for directive %a@.@?"

646

print_directive directive;

647

let _ =

648

match !target with

649

 Some dir' >

650

Format.eprintf "New directive %a@.@?" print_directive dir'

651

 _ >

652

()

653

in

654

assert false

655

(* The mutation has not been performed. *)

656

in

657


658

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

659

visit *)*)

660

prog', mutation_info

661


662

let op_mutation op =

663

let res =

664

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

665

if List.mem op arith_op then rem_op arith_op

666

else if List.mem op bool_op then rem_op bool_op

667

else if List.mem op rel_op then rem_op rel_op

668

else (

669

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

670

assert false)

671

in

672

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

673

Format.pp_print_string) res; *)

674

res

675


676

let rec remains select list =

677

match list with

678

 [] >

679

[]

680

 hd :: tl >

681

if select hd then tl else remains select tl

682


683

let next_change m =

684

let res =

685

let rec first_op () =

686

try

687

let min_binding = OpCount.min_binding !records.nb_op in

688

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

689

with Not_found > first_boolexpr ()

690

and first_boolexpr () =

691

if !records.nb_boolexpr > 0 then Boolexpr 0 else first_pre ()

692

and first_pre () = if !records.nb_pre > 0 then Pre 0 else first_op ()

693

and first_intcst () =

694

if IntSet.cardinal !records.consts > 0 then IncrIntCst 0

695

else first_boolexpr ()

696

in

697

match m with

698

 Boolexpr n >

699

if n + 1 >= !records.nb_boolexpr then first_pre () else Boolexpr (n + 1)

700

 Pre n >

701

if n + 1 >= !records.nb_pre then first_op () else Pre (n + 1)

702

 Op (orig, id, mut_op) > (

703

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

704

 next_op :: _ >

705

Op (orig, id, next_op)

706

 [] >

707

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

708

match

709

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

710

with

711

 [] >

712

first_intcst ()

713

 hd :: _ >

714

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

715

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

716

 IncrIntCst n >

717

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

718

else IncrIntCst (n + 1)

719

 DecrIntCst n >

720

if n + 1 >= IntSet.cardinal !records.consts then SwitchIntCst (0, 0)

721

else DecrIntCst (n + 1)

722

 SwitchIntCst (n, m) >

723

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

724

SwitchIntCst (n, m + 1)

725

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

726

SwitchIntCst (n + 1, 0)

727

else first_boolexpr ()

728

in

729


730

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

731

res

732


733

let fold_mutate nb prog =

734

incr random_seed;

735

Random.init !random_seed;

736


737

(* Local references to keep track of generated directives *)

738


739

(* build a set of integer 0, 1, ... n1 for input n *)

740

let cpt_to_intset cpt =

741

let arr = Array.init cpt (fun x > x) in

742

Array.fold_right IntSet.add arr IntSet.empty

743

in

744


745

let possible_const_id = cpt_to_intset !records.nb_consts in

746


747

(* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)

748

(* let possible_pre_id = cpt_to_intset !records.nb_pre in *)

749

let incremented_const_id = ref IntSet.empty in

750

let decremented_const_id = ref IntSet.empty in

751


752

let create_new_incr_decr registered build =

753

let possible =

754

IntSet.diff possible_const_id !registered > IntSet.elements

755

in

756

let len = List.length possible in

757

if len <= 0 then false, build (1) (* Should not be stored *)

758

else

759

let picked = List.nth possible (Random.int (List.length possible)) in

760

registered := IntSet.add picked !registered;

761

true, build picked

762

in

763


764

let module DblIntSet = Set.Make (struct

765

type t = int * int

766


767

let compare = compare

768

end) in

769

let switch_const_id = ref DblIntSet.empty in

770

let switch_set =

771

if IntSet.cardinal !records.consts <= 1 then DblIntSet.empty

772

else

773

(* First element is cst id (the ith cst) while second is the ith element

774

of the set of gathered constants !record.consts *)

775

IntSet.fold

776

(fun cst_id set >

777

IntSet.fold

778

(fun ith_cst set > DblIntSet.add (cst_id, ith_cst) set)

779

!records.consts set)

780

possible_const_id DblIntSet.empty

781

in

782


783

let create_new_switch registered build =

784

let possible =

785

DblIntSet.diff switch_set !registered > DblIntSet.elements

786

in

787

let len = List.length possible in

788

if len <= 0 then false, build (1, 1) (* Should not be stored *)

789

else

790

let picked = List.nth possible (Random.int (List.length possible)) in

791

registered := DblIntSet.add picked !registered;

792

true, build picked

793

in

794


795

let find_next_new mutants mutant =

796

let find_next_new init current =

797

if init = current  List.mem current mutants then raise Not_found

798

else

799

(* TODO: check if we can generate more cases. The following lines were

800

cylcing and missing to detect that the enumaration was complete,

801

leading to a non terminating process. The current setting is harder

802

but may miss enumerating some cases. To be checked! *)

803


804

(* if List.mem current mutants then *)

805

(* find_next_new init (next_change current) *)

806

(* else *)

807

current

808

in

809

find_next_new mutant (next_change mutant)

810

in

811

(* Creating list of nb elements of mutants *)

812

let rec create_mutants_directives rnb mutants =

813

if rnb <= 0 then mutants

814

else

815

(* Initial list of transformation *)

816

let rec init_list x = if x <= 0 then [ 0 ] else x :: init_list (x  1) in

817

let init_list = init_list 5 in

818

(* We generate a random permutation of the list: the first item is the

819

transformation, the rest of the list act as fallback choices to make

820

sure we produce something *)

821

let shuffle l =

822

let nd = List.map (fun c > Random.bits (), c) l in

823

let sond = List.sort compare nd in

824

List.map snd sond

825

in

826

let transforms = shuffle init_list in

827

let rec apply_transform transforms =

828

let f id =

829

match id with

830

 5 >

831

create_new_incr_decr incremented_const_id (fun x > IncrIntCst x)

832

 4 >

833

create_new_incr_decr decremented_const_id (fun x > DecrIntCst x)

834

 3 >

835

create_new_switch switch_const_id (fun (x, y) >

836

SwitchIntCst (x, y))

837

 2 >

838

( !records.nb_pre > 0,

839

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

840

 1 >

841

( !records.nb_boolexpr > 0,

842

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

843

 0 >

844

let bindings = OpCount.bindings !records.nb_op in

845

let bindings_len = List.length bindings in

846

if bindings_len > 0 then

847

let op, nb_op =

848

List.nth bindings (try Random.int bindings_len with _ > 0)

849

in

850

let op_mut = op_mutation op in

851

let new_op =

852

List.nth op_mut

853

(try Random.int (List.length op_mut) with _ > 0)

854

in

855

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

856

else false, Boolexpr 0

857

(* Providing a dummy construct, it will be filtered out thanks to the

858

negative status (fst = false) *)

859

 _ >

860

assert false

861

in

862

match transforms with

863

 [] >

864

assert false

865

 [ hd ] >

866

f hd

867

 hd :: tl >

868

let ok, random_mutation = f hd in

869

if ok then ok, random_mutation else apply_transform tl

870

in

871

let ok, random_mutation = apply_transform transforms in

872

let stop_process () =

873

report ~level:1 (fun fmt >

874

fprintf fmt

875

"Only %i mutants directives generated out of %i expected@ "

876

(nb  rnb) nb);

877

mutants

878

in

879

if not ok then stop_process ()

880

else if List.mem random_mutation mutants then

881

try

882

let new_mutant = find_next_new mutants random_mutation in

883

report ~level:2 (fun fmt >

884

fprintf fmt " %i mutants directive generated out of %i expected@ "

885

(nb  rnb) nb);

886

create_mutants_directives (rnb  1) (new_mutant :: mutants)

887

with Not_found > stop_process ()

888

else create_mutants_directives (rnb  1) (random_mutation :: mutants)

889

in

890

let mutants_directives = create_mutants_directives nb [] in

891

List.map

892

(fun d >

893

let mutant, loc = create_mutant prog d in

894

d, loc, mutant)

895

mutants_directives

896


897

let mutate nb prog =

898

records := compute_records prog;

899

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

900

(* !records.nb_pre *)

901

(* !records.nb_boolexpr *)

902

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

903

(* ; *)

904

fold_mutate nb prog

905


906

(* Local Variables: *)

907

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

908

(* End: *)
