1


2

(* Comments in function fold_mutate

3


4

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

5

cylcing and missing to detect that the enumaration was complete,

6

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

7

but may miss enumerating some cases. To be checked!

8


9


10

*)

11


12


13

open Lustre_types

14

open Corelang

15

open Log

16

open Format

17


18

let random_seed = ref 0

19

let threshold_delay = 95

20

let threshold_inc_int = 97

21

let threshold_dec_int = 97

22

let threshold_random_int = 96

23

let threshold_switch_int = 100 (* not implemented yet *)

24

let threshold_random_float = 100 (* not used yet *)

25

let threshold_negate_bool_var = 95

26

let threshold_arith_op = 95

27

let threshold_rel_op = 95

28

let threshold_bool_op = 95

29


30

let int_consts = ref []

31


32

let rename_app id =

33

if List.mem id Basic_library.internal_funs 

34

!Options.no_mutation_suffix then

35

id

36

else

37

let node = Corelang.node_from_name id in

38

let is_imported =

39

match node.top_decl_desc with

40

 ImportedNode _ > true

41

 _ > false

42

in

43

if is_imported then

44

id

45

else

46

id ^ "_mutant"

47


48

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

49

(* Gathering constants in the code *)

50

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

51


52

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

53

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

54


55

type records = {

56

consts: IntSet.t;

57

nb_consts: int;

58

nb_boolexpr: int;

59

nb_pre: int;

60

nb_op: int OpCount.t;

61

}

62


63

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

64

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

65

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

66

let ops = arith_op @ bool_op @ rel_op

67

let all_ops = "not" :: ops

68


69

let empty_records =

70

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

71


72

let records = ref empty_records

73


74

let merge_records records_list =

75

let merge_record r1 r2 =

76

{

77

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

78


79

nb_consts = r1.nb_consts + r2.nb_consts;

80

nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;

81

nb_pre = r1.nb_pre + r2.nb_pre;

82


83

nb_op = OpCount.merge (fun op r1opt r2opt >

84

match r1opt, r2opt with

85

 None, _ > r2opt

86

 _, None > r1opt

87

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

88

) r1.nb_op r2.nb_op

89

}

90

in

91

List.fold_left merge_record empty_records records_list

92


93

let compute_records_const_value c =

94

match c with

95

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

96

 _ > empty_records

97


98

let rec compute_records_expr expr =

99

let boolexpr =

100

if Types.is_bool_type expr.expr_type then

101

{empty_records with nb_boolexpr = 1}

102

else

103

empty_records

104

in

105

let subrec =

106

match expr.expr_desc with

107

 Expr_const c > compute_records_const_value c

108

 Expr_tuple l > merge_records (List.map compute_records_expr l)

109

 Expr_ite (i,t,e) >

110

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

111

 Expr_arrow (e1, e2) >

112

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

113

 Expr_pre e >

114

merge_records (

115

({empty_records with nb_pre = 1})

116

::[compute_records_expr e])

117

 Expr_appl (op_id, args, r) >

118

if List.mem op_id ops then

119

merge_records (

120

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

121

::[compute_records_expr args])

122

else

123

compute_records_expr args

124

 _ > empty_records

125

in

126

merge_records [boolexpr;subrec]

127


128

let compute_records_eq eq = compute_records_expr eq.eq_rhs

129


130

let compute_records_node nd =

131

let eqs, auts = get_node_eqs nd in

132

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

133

merge_records (List.map compute_records_eq eqs)

134


135

let compute_records_top_decl td =

136

match td.top_decl_desc with

137

 Node nd > compute_records_node nd

138

 Const cst > compute_records_const_value cst.const_value

139

 _ > empty_records

140


141

let compute_records prog =

142

merge_records (List.map compute_records_top_decl prog)

143


144

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

145

(* Random mutation *)

146

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

147


148

let check_mut e1 e2 =

149

let rec eq e1 e2 =

150

match e1.expr_desc, e2.expr_desc with

151

 Expr_const c1, Expr_const c2 > c1 = c2

152

 Expr_ident id1, Expr_ident id2 > id1 = id2

153

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

154

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

155

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

156

 Expr_pre e1, Expr_pre e2 > eq e1 e2

157

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

158

 _ > false

159

in

160

if not (eq e1 e2) then

161

Some (e1, e2)

162

else

163

None

164


165

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

166


167

let rdm_mutate_int i =

168

if Random.int 100 > threshold_inc_int then

169

i+1

170

else if Random.int 100 > threshold_dec_int then

171

i1

172

else if Random.int 100 > threshold_random_int then

173

Random.int 10

174

else if Random.int 100 > threshold_switch_int then

175

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

176

List.nth !int_consts idx

177

else

178

i

179


180

let rdm_mutate_real r =

181

if Random.int 100 > threshold_random_float then

182

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

183

let bound = 10 in

184

(* max number of digits after comma *)

185

let digits = 5 in

186

(* number of digits after comma *)

187

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

188

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

189

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

190

let f = float_of_int i /. eshift in

191

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

192

else

193

r

194


195

let rdm_mutate_op op =

196

match op with

197

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

198

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

199

List.nth filtered (Random.int 3)

200

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

201

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

202

List.nth filtered (Random.int 3)

203

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

204

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

205

List.nth filtered (Random.int 5)

206

 _ > op

207


208


209

let rdm_mutate_var expr =

210

if Types.is_bool_type expr.expr_type then

211

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

212

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

213

Some (expr, new_e), new_e

214

(* else *)

215

(* expr *)

216

else

217

None, expr

218


219

let rdm_mutate_pre orig_expr =

220

let new_e = Expr_pre orig_expr in

221

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

222


223


224

let rdm_mutate_const_value c =

225

match c with

226

 Const_int i > Const_int (rdm_mutate_int i)

227

 Const_real r > Const_real (rdm_mutate_real r)

228

 Const_array _

229

 Const_string _

230

 Const_modeid _

231

 Const_struct _

232

 Const_tag _ > c

233


234

let rdm_mutate_const c =

235

let new_const = rdm_mutate_const_value c.const_value in

236

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

237

mut, { c with const_value = new_const }

238


239


240

let select_in_list list rdm_mutate_elem =

241

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

242

let mutation_opt, new_list, _ =

243

List.fold_right

244

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

245

let mutation, new_elem = rdm_mutate_elem elem in

246

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

247

list

248

(None, [], 0)

249

in

250

match mutation_opt with

251

 Some mut > mut, new_list

252

 _ > assert false

253


254


255

let rec rdm_mutate_expr expr =

256

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

257

match expr.expr_desc with

258

 Expr_ident id > rdm_mutate_var expr

259

 Expr_const c >

260

let new_const = rdm_mutate_const_value c in

261

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

262

mut, mk_e (Expr_const new_const)

263

 Expr_tuple l >

264

let mut, l' = select_in_list l rdm_mutate_expr in

265

mut, mk_e (Expr_tuple l')

266

 Expr_ite (i,t,e) > (

267

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

268

match l with

269

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

270

 _ > assert false

271

)

272

 Expr_arrow (e1, e2) > (

273

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

274

match l with

275

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

276

 _ > assert false

277

)

278

 Expr_pre e >

279

let select_pre = Random.bool () in

280

if select_pre then

281

let mut, new_expr = rdm_mutate_pre expr in

282

mut, mk_e new_expr

283

else

284

let mut, e' = rdm_mutate_expr e in

285

mut, mk_e (Expr_pre e')

286

 Expr_appl (op_id, args, r) >

287

let select_op = Random.bool () in

288

if select_op then

289

let new_op_id = rdm_mutate_op op_id in

290

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

291

let mut = check_mut expr new_e in

292

mut, new_e

293

else

294

let mut, new_args = rdm_mutate_expr args in

295

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

296

(* Other constructs are kept.

297

 Expr_fby of expr * expr

298

 Expr_array of expr list

299

 Expr_access of expr * Dimension.dim_expr

300

 Expr_power of expr * Dimension.dim_expr

301

 Expr_when of expr * ident * label

302

 Expr_merge of ident * (label * expr) list

303

 Expr_uclock of expr * int

304

 Expr_dclock of expr * int

305

 Expr_phclock of expr * rat *)

306

 _ > None, expr

307


308


309

let rdm_mutate_eq eq =

310

let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in

311

mutation, { eq with eq_rhs = new_rhs }

312


313

let rnd_mutate_stmt stmt =

314

match stmt with

315

 Eq eq > let mut, new_eq = rdm_mutate_eq eq in

316

report ~level:1

317

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

318

Printers.pp_node_eq eq

319

Printers.pp_node_eq new_eq);

320

mut, Eq new_eq

321

 Aut aut > assert false

322


323

let rdm_mutate_node nd =

324

let mutation, new_node_stmts =

325

select_in_list

326

nd.node_stmts rnd_mutate_stmt

327

in

328

mutation, { nd with node_stmts = new_node_stmts }

329


330

let rdm_mutate_top_decl td =

331

match td.top_decl_desc with

332

 Node nd >

333

let mutation, new_node = rdm_mutate_node nd in

334

mutation, { td with top_decl_desc = Node new_node}

335

 Const cst >

336

let mut, new_cst = rdm_mutate_const cst in

337

mut, { td with top_decl_desc = Const new_cst }

338

 _ > None, td

339


340

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

341

let rdm_mutate_prog prog =

342

select_in_list prog rdm_mutate_top_decl

343


344

let rdm_mutate nb prog =

345

let rec iterate nb res =

346

incr random_seed;

347

if nb <= 0 then

348

res

349

else (

350

Random.init !random_seed;

351

let mutation, new_mutant = rdm_mutate_prog prog in

352

match mutation with

353

None > iterate nb res

354

 Some mutation > (

355

if List.mem_assoc mutation res then (

356

iterate nb res

357

)

358

else (

359

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

360

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

361

)

362

)

363

)

364

in

365

iterate nb []

366


367


368

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

369

(* Random mutation *)

370

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

371


372

type mutant_t =

373

 Boolexpr of int

374

 Pre of int

375

 Op of string * int * string

376

 IncrIntCst of int

377

 DecrIntCst of int

378

 SwitchIntCst of int * int

379


380

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

381

type mutation_loc = ident * ident list * Location.t

382

let target : mutant_t option ref = ref None

383


384

let mutation_info : mutation_loc option ref = ref None

385

let current_node: ident option ref = ref None

386

let current_eq_lhs : ident list option ref = ref None

387

let current_loc : Location.t option ref = ref None

388


389

let set_mutation_loc () =

390

target := None;

391

match !current_node, !current_eq_lhs, !current_loc with

392

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

393

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

394

visitor pattern execution *)

395


396

let print_directive fmt d =

397

match d with

398

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

399

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

400

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

401

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

402

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

403

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

404


405

let print_directive_json fmt d =

406

match d with

407

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

408

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

409

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

410

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

411

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

412

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

413


414

let print_loc_json fmt (n,eqlhs, l) =

415

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

416

n

417

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

418

(Location.loc_line l)

419


420

let fold_mutate_int i =

421

if Random.int 100 > threshold_inc_int then

422

i+1

423

else if Random.int 100 > threshold_dec_int then

424

i1

425

else if Random.int 100 > threshold_random_int then

426

Random.int 10

427

else if Random.int 100 > threshold_switch_int then

428

try

429

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

430

List.nth !int_consts idx

431

with _ > i

432

else

433

i

434


435

let fold_mutate_float f =

436

if Random.int 100 > threshold_random_float then

437

Random.float 10.

438

else

439

f

440


441

let fold_mutate_op op =

442

(* match op with *)

443

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

444

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

445

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

446

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

447

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

448

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

449

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

450

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

451

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

452

(*  _ > op *)

453

match !target with

454

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

455

set_mutation_loc ();

456

op_new

457

)

458

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

459

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

460

op

461

)

462

 _ > op

463


464


465

let fold_mutate_var expr =

466

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

467

(*  Types.Tbool > *)

468

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

469

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

470

(* (\* else *\) *)

471

(* (\* expr *\) *)

472

(*  _ >

473

*)expr

474


475

let fold_mutate_boolexpr expr =

476

match !target with

477

 Some (Boolexpr 0) > (

478

set_mutation_loc ();

479


480

mkpredef_call expr.expr_loc "not" [expr]

481

)

482

 Some (Boolexpr n) >

483

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

484

 _ > expr

485


486

let fold_mutate_pre orig_expr e =

487

match !target with

488

Some (Pre 0) > (

489

set_mutation_loc ();

490

Expr_pre ({orig_expr with expr_desc = Expr_pre e})

491

)

492

 Some (Pre n) > (

493

target := Some (Pre (n1));

494

Expr_pre e

495

)

496

 _ > Expr_pre e

497


498

let fold_mutate_const_value c =

499

match c with

500

 Const_int i > (

501

match !target with

502

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

503

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

504

 Some (SwitchIntCst (0, id)) >

505

(set_mutation_loc (); Const_int id)

506

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

507

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

508

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

509

 _ > c)

510

 _ > c

511


512

(*

513

match c with

514

 Const_int i > Const_int (fold_mutate_int i)

515

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

516

 Const_float f > Const_float (fold_mutate_float f)

517

 Const_array _

518

 Const_tag _ > c

519

TODO

520


521

*)

522

let fold_mutate_const c =

523

{ c with const_value = fold_mutate_const_value c.const_value }

524


525

let rec fold_mutate_expr expr =

526

current_loc := Some expr.expr_loc;

527

let new_expr =

528

match expr.expr_desc with

529

 Expr_ident id > fold_mutate_var expr

530

 _ > (

531

let new_desc = match expr.expr_desc with

532

 Expr_const c > Expr_const (fold_mutate_const_value c)

533

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

534

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

535

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

536

 Expr_pre e > fold_mutate_pre expr (fold_mutate_expr e)

537

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

538

(* Other constructs are kept.

539

 Expr_fby of expr * expr

540

 Expr_array of expr list

541

 Expr_access of expr * Dimension.dim_expr

542

 Expr_power of expr * Dimension.dim_expr

543

 Expr_when of expr * ident * label

544

 Expr_merge of ident * (label * expr) list

545

 Expr_uclock of expr * int

546

 Expr_dclock of expr * int

547

 Expr_phclock of expr * rat *)

548

 _ > expr.expr_desc

549


550

in

551

{ expr with expr_desc = new_desc }

552

)

553

in

554

if Types.is_bool_type expr.expr_type then

555

fold_mutate_boolexpr new_expr

556

else

557

new_expr

558


559

let fold_mutate_eq eq =

560

current_eq_lhs := Some eq.eq_lhs;

561

{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }

562


563

let fold_mutate_stmt stmt =

564

match stmt with

565

 Eq eq > Eq (fold_mutate_eq eq)

566

 Aut aut > assert false

567


568


569

let fold_mutate_node nd =

570

current_node := Some nd.node_id;

571

let nd =

572

{ nd with

573

node_stmts =

574

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

575

}

576

in

577

rename_node rename_app (fun x > x) nd

578


579

let fold_mutate_top_decl td =

580

match td.top_decl_desc with

581

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

582

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

583

 _ > td

584


585

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

586

let fold_mutate_prog prog =

587

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

588


589

let create_mutant prog directive =

590

target := Some directive;

591

let prog' = fold_mutate_prog prog in

592

let mutation_info = match !target , !mutation_info with

593

 None, Some mi > mi

594

 _ > (

595

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

596

let _ = match !target with Some dir' > Format.eprintf "New directive %a@.@?" print_directive dir'  _ > () in

597

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

598

)

599


600

in

601

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

602

visit *)*)

603

prog', mutation_info

604


605


606

let op_mutation op =

607

let res =

608

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

609

if List.mem op arith_op then rem_op arith_op else

610

if List.mem op bool_op then rem_op bool_op else

611

if List.mem op rel_op then rem_op rel_op else

612

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

613

assert false

614

)

615

in

616

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

617

res

618


619

let rec remains select list =

620

match list with

621

[] > []

622

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

623


624

let next_change m =

625

let res =

626

let rec first_op () =

627

try

628

let min_binding = OpCount.min_binding !records.nb_op in

629

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

630

with Not_found > first_boolexpr ()

631

and first_boolexpr () =

632

if !records.nb_boolexpr > 0 then

633

Boolexpr 0

634

else first_pre ()

635

and first_pre () =

636

if !records.nb_pre > 0 then

637

Pre 0

638

else

639

first_op ()

640

and first_intcst () =

641

if IntSet.cardinal !records.consts > 0 then

642

IncrIntCst 0

643

else

644

first_boolexpr ()

645

in

646

match m with

647

 Boolexpr n >

648

if n+1 >= !records.nb_boolexpr then

649

first_pre ()

650

else

651

Boolexpr (n+1)

652

 Pre n >

653

if n+1 >= !records.nb_pre then

654

first_op ()

655

else Pre (n+1)

656

 Op (orig, id, mut_op) > (

657

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

658

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

659

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

660

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

661

 [] > first_intcst ()

662

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

663

) else

664

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

665

)

666

 IncrIntCst n >

667

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

668

DecrIntCst 0

669

else IncrIntCst (n+1)

670

 DecrIntCst n >

671

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

672

SwitchIntCst (0, 0)

673

else DecrIntCst (n+1)

674

 SwitchIntCst (n, m) >

675

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

676

SwitchIntCst (n, m+1)

677

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

678

SwitchIntCst (n+1, 0)

679

else first_boolexpr ()

680


681

in

682

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

683

res

684


685

let fold_mutate nb prog =

686

incr random_seed;

687

Random.init !random_seed;

688

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

689


690

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

691

let cpt_to_intset cpt =

692

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

693

Array.fold_right IntSet.add arr IntSet.empty

694

in

695


696

let possible_const_id = cpt_to_intset !records.nb_consts in

697

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

698

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

699


700

let incremented_const_id = ref IntSet.empty in

701

let decremented_const_id = ref IntSet.empty in

702


703

let create_new_incr_decr registered build =

704

let possible = IntSet.diff possible_const_id !registered > IntSet.elements in

705

let len = List.length possible in

706

if len <= 0 then

707

false, build (1) (* Should not be stored *)

708

else

709

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

710

registered := IntSet.add picked !registered;

711

true, build picked

712

in

713


714


715

let module DblIntSet = Set.Make (struct type t = int * int let compare = compare end) in

716

let switch_const_id = ref DblIntSet.empty in

717

let switch_set =

718

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

719

DblIntSet.empty

720

else

721

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

722

ith element of the set of gathered constants

723

!record.consts *)

724

IntSet.fold (fun cst_id set >

725

IntSet.fold (fun ith_cst set >

726

DblIntSet.add (cst_id, ith_cst) set

727

) !records.consts set

728

) possible_const_id DblIntSet.empty

729

in

730


731

let create_new_switch registered build =

732

let possible = DblIntSet.diff switch_set !registered > DblIntSet.elements in

733

let len = List.length possible in

734

if len <= 0 then

735

false, build (1,1) (* Should not be stored *)

736

else

737

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

738

registered := DblIntSet.add picked !registered;

739

true, build picked

740

in

741


742

let find_next_new mutants mutant =

743

let rec find_next_new init current =

744

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

745


746

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

747

cylcing and missing to detect that the enumaration was complete,

748

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

749

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

750


751

(* if List.mem current mutants then *)

752

(* find_next_new init (next_change current) *)

753

(* else *)

754

current

755

in

756

find_next_new mutant (next_change mutant)

757

in

758

(* Creating list of nb elements of mutants *)

759

let rec create_mutants_directives rnb mutants =

760

if rnb <= 0 then mutants

761

else

762

(* Initial list of transformation *)

763

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

764

let init_list = init_list 5 in

765

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

766

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

767

sure we produce something *)

768

let shuffle l =

769

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

770

let sond = List.sort compare nd in

771

List.map snd sond

772

in

773

let transforms = shuffle init_list in

774

let rec apply_transform transforms =

775

let f id =

776

match id with

777

 5 > create_new_incr_decr incremented_const_id (fun x > IncrIntCst x)

778

 4 > create_new_incr_decr decremented_const_id (fun x > DecrIntCst x)

779

 3 > create_new_switch switch_const_id (fun (x,y) > SwitchIntCst(x, y))

780

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

781

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

782

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

783

let bindings_len = List.length bindings in

784

if bindings_len > 0 then

785

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

786

let op_mut = op_mutation op in

787

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

788

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

789

else

790

false, Boolexpr 0 (* Providing a dummy construct,

791

it will be filtered out thanks

792

to the negative status (fst =

793

false) *)

794

 _ > assert false

795

in

796

match transforms with

797

 [] > assert false

798

 [hd] > f hd

799

 hd::tl > let ok, random_mutation = f hd in

800

if ok then

801

ok, random_mutation

802

else

803

apply_transform tl

804

in

805

let ok, random_mutation = apply_transform transforms in

806

let stop_process () =

807

report ~level:1 (fun fmt > fprintf fmt

808

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

809

(nbrnb)

810

nb);

811

mutants

812

in

813

if not ok then

814

stop_process ()

815

else if List.mem random_mutation mutants then

816

try

817

let new_mutant = (find_next_new mutants random_mutation) in

818

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

819

create_mutants_directives (rnb1) (new_mutant::mutants)

820

with Not_found > (

821

stop_process ()

822

)

823

else (

824

create_mutants_directives (rnb1) (random_mutation::mutants)

825

)

826

in

827

let mutants_directives = create_mutants_directives nb [] in

828

List.map (fun d >

829

let mutant, loc = create_mutant prog d in

830

d, loc, mutant ) mutants_directives

831


832


833

let mutate nb prog =

834

records := compute_records prog;

835

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

836

(* !records.nb_pre *)

837

(* !records.nb_boolexpr *)

838

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

839

(* ; *)

840

fold_mutate nb prog

841


842


843


844


845

(* Local Variables: *)

846

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

847

(* End: *)

848


849

