Project

General

Profile

Revision 7ecfca04

View differences:

Makefile.in
17 17
	@mkdir -p $(LOCAL_BINDIR)
18 18
	@mv _build/src/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
19 19

  
20
$(LOCAL_BINDIR)/lustrem: configure Makefile
21
	@echo Compiling binary lustrem
22
	@$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -lflag nums.cmxa -I src -I src/backends/C -I src/plugins/scopes src/main_lustre_mutator.native
23
	@mkdir -p $(LOCAL_BINDIR)
24
	@mv _build/src/main_lustre_mutator.native $(LOCAL_BINDIR)/lustrem
25

  
20 26
configure: configure.ac
21 27
	@echo configure.ac has changed relaunching autoconf
22 28
	@autoconf
src/_tags
5 5
"main_lustre_compiler.native": package(ocamlgraph)
6 6
"main_lustre_compiler.native": use_str
7 7
"main_lustre_compiler.native": use_unix
8
"main_lustre_mutator.native": package(ocamlgraph)
9
"main_lustre_mutator.native": use_str
10
"main_lustre_mutator.native": use_unix
8 11
<*.ml{,i}>: package(ocamlgraph)
9 12
<*.ml{,i}>: use_str
10 13
<*.ml{,i}>: use_unix
src/corelang.ml
96 96
let mkpredef_call loc funname args =
97 97
  mkexpr loc (Expr_appl (funname, mkexpr loc (Expr_tuple args), None))
98 98

  
99
let mkpredef_unary_call loc funname arg =
100
  mkexpr loc (Expr_appl (funname, arg, None))
101

  
99 102
let is_clock_dec_type cty =
100 103
  match cty with
101 104
  | Tydec_clock _ -> true
src/corelang.mli
27 27
val mkassert: Location.t -> expr -> assert_t
28 28
val mktop_decl: Location.t -> ident -> bool -> top_decl_desc -> top_decl
29 29
val mkpredef_call: Location.t -> ident -> expr list -> expr
30
val mkpredef_unary_call: Location.t -> ident -> expr -> expr
30 31
val mk_new_name: (ident -> bool) -> ident -> ident
31 32
val mk_new_node_name: node_desc -> ident -> ident
32 33
val mktop: top_decl_desc -> top_decl
src/main_lustre_compiler.ml
22 22

  
23 23
let extensions = [".ec"; ".lus"; ".lusi"]
24 24

  
25
let check_stateless_decls decls =
26
  report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@,@?");
27
  try
28
    Stateless.check_prog decls
29
  with (Stateless.Error (loc, err)) as exc ->
30
    Format.eprintf "Stateless status error at loc %a: %a@]@."
31
      Location.pp_loc loc
32
      Stateless.pp_error err;
33
    raise exc
25
(* print a .lusi header file from a source prog *)
26
let print_lusi prog dirname basename extension =
27
  let header = Lusic.extract_header dirname basename prog in
28
  let header_name = dirname ^ "/" ^ basename ^ extension in
29
  let h_out = open_out header_name in
30
  let h_fmt = formatter_of_out_channel h_out in
31
  begin
32
    Typing.uneval_prog_generics header;
33
    Clock_calculus.uneval_prog_generics header;
34
    Printers.pp_lusi_header h_fmt basename header;
35
    close_out h_out
36
  end
37

  
38
(* compile a .lusi header file *)
39
let compile_header dirname  basename extension =
40
  let destname = !Options.dest_dir ^ "/" ^ basename in
41
  let header_name = basename ^ extension in
42
  let lusic_ext = extension ^ "c" in
43
  begin
44
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
45
    let header = parse_header true (dirname ^ "/" ^ header_name) in
46
    ignore (Modules.load_header ISet.empty header);
47
    ignore (check_top_decls header);
48
    create_dest_dir ();
49
    Log.report ~level:1
50
      (fun fmt -> fprintf fmt ".. generating compiled header file %sc@," (destname ^ extension));
51
    Lusic.write_lusic true header destname lusic_ext;
52
    Lusic.print_lusic_to_h destname lusic_ext;
53
    Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.")
54
  end
55

  
56
(* check whether a source file has a compiled header,
57
   if not, generate the compiled header *)
58
let compile_source_to_header prog computed_types_env computed_clocks_env dirname basename extension =
59
  let destname = !Options.dest_dir ^ "/" ^ basename in
60
  let lusic_ext = extension ^ "c" in
61
  let header_name = destname ^ lusic_ext in
62
  begin
63
    if not (Sys.file_exists header_name) then
64
      begin
65
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);
66
	Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;
67
	Lusic.print_lusic_to_h destname lusic_ext
68
      end
69
    else
70
      let lusic = Lusic.read_lusic destname lusic_ext in
71
      if not lusic.Lusic.from_lusi then
72
	begin
73
	  Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating compiled header file %s@," header_name);
74
       	  Lusic.write_lusic false (Lusic.extract_header dirname basename prog) destname lusic_ext;
75
	  (*List.iter (fun top_decl -> Format.eprintf "lusic: %a@." Printers.pp_decl top_decl) lusic.Lusic.contents;*)
76
	  Lusic.print_lusic_to_h destname lusic_ext
77
	end
78
      else
79
	begin
80
	  Log.report ~level:1 (fun fmt -> fprintf fmt ".. loading compiled header file %s@," header_name);
81
	  Modules.check_dependency lusic destname;
82
	  let header = lusic.Lusic.contents in
83
	  let (declared_types_env, declared_clocks_env) = get_envs_from_top_decls header in
84
	  check_compatibility
85
	    (prog, computed_types_env, computed_clocks_env)
86
	    (header, declared_types_env, declared_clocks_env)
87
	end
88
  end
89

  
90

  
91
let functional_backend () = 
92
  match !Options.output with
93
  | "horn" | "lustre" | "acsl" -> true
94
  | _ -> false
95

  
96
(* From prog to prog *)
97
let stage1 prog dirname basename =
98
  (* Removing automata *) 
99
  let prog = expand_automata prog in
100

  
101
  Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@.@[<v 2>@ %a@]@," Printers.pp_prog prog);
102

  
103
  (* Importing source *)
104
  let _ = Modules.load_program ISet.empty prog in
34 105

  
35
let type_decls env decls =  
36
  report ~level:1 (fun fmt -> fprintf fmt ".. typing@,@?");
37
  let new_env = 
38
    begin
39
      try
40
	Typing.type_prog env decls
41
      with (Types.Error (loc,err)) as exc ->
42
	Format.eprintf "Typing error at loc %a: %a@]@."
43
	  Location.pp_loc loc
44
	  Types.pp_error err;
45
	raise exc
46
    end 
47
  in
48
  if !Options.print_types then
49
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_type decls);
50
  new_env
51
      
52
let clock_decls env decls = 
53
  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");
54
  let new_env =
55
    begin
56
      try
57
	Clock_calculus.clock_prog env decls
58
      with (Clocks.Error (loc,err)) as exc ->
59
	Location.print loc;
60
	eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;
61
	raise exc
62
    end
63
  in
64
  if !Options.print_clocks then
65
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);
66
  new_env
67

  
68
(* Loading Lusi file and filling type tables with parsed
69
   functions/nodes *)
70
let load_lusi own filename =
71
  Location.input_name := filename;
72
  let lexbuf = Lexing.from_channel (open_in filename) in
73
  Location.init lexbuf filename;
74
  (* Parsing *)
75
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
76
  try
77
    Parse.header own Parser_lustre.header Lexer_lustre.token lexbuf
78
  with
79
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
80
    Parse.report_error err;
81
    raise exc
82
  | Corelang.Error (loc, err) as exc ->
83
     Format.eprintf "Parsing error at loc %a: %a@]@."
84
       Location.pp_loc loc
85
       Corelang.pp_error err;
86
     raise exc
87

  
88
let check_lusi header =
89
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
90
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
91
  header, new_tenv, new_cenv
92
    
93
let rec compile basename extension =
94
  (* Loading the input file *)
95
  let source_name = basename^extension in
96
  Location.input_name := source_name;
97
  let lexbuf = Lexing.from_channel (open_in source_name) in
98
  Location.init lexbuf source_name;
99
  (* Parsing *)
100
  report ~level:1 
101
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
102
  let prog =
103
    try
104
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
105
    with
106
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
107
      Parse.report_error err;
108
      raise exc
109
    | Corelang.Error (loc, err) as exc ->
110
      Format.eprintf "Parsing error at loc %a: %a@]@."
111
	Location.pp_loc loc
112
	Corelang.pp_error err;
113
      raise exc
114
  in
115 106
  (* Extracting dependencies *)
116 107
  let dependencies, type_env, clock_env = import_dependencies prog in
117 108

  
src/main_lustre_mutator.ml
1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE
5
 *
6
 * This file is part of Prelude
7
 *
8
 * Prelude is free software; you can redistribute it and/or
9
 * modify it under the terms of the GNU Lesser General Public License
10
 * as published by the Free Software Foundation ; either version 2 of
11
 * the License, or (at your option) any later version.
12
 *
13
 * Prelude is distributed in the hope that it will be useful, but
14
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
15
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16
 * Lesser General Public License for more details.
17
 *
18
 * You should have received a copy of the GNU Lesser General Public
19
 * License along with this program ; if not, write to the Free Software
20
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
21
 * USA
22
 *---------------------------------------------------------------------------- *)
23

  
24
(* This module is used for the lustre mutator *)
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
25 11

  
26 12
open Format
27 13
open Log
28
open Load
29

  
30
let usage = "Usage: lustrem [options] <source-file>"
31

  
32
let extensions = [".ec";".lus"]
33

  
34
      
35
let clock_decls env decls = 
36
  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");
37
  let new_env =
38
    begin
39
      try
40
	Clock_calculus.clock_prog env decls
41
      with (Clocks.Error (loc,err)) as exc ->
42
	Location.print loc;
43
	eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;
44
	raise exc
45
    end
46
  in
47
  if !Options.print_clocks then
48
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);
49
  new_env
50
  
51
    
52
let rec mutate basename extension =
53
  (* Loading the input file *)
54
  let source_name = basename^extension in
55
  Location.input_name := source_name;
56
  let lexbuf = Lexing.from_channel (open_in source_name) in
57
  Location.init lexbuf source_name;
58

  
59
  (* Parsing *)
60
  report ~level:1 
61
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
62
  let prog =
63
    try
64
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
65
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
66
      Parse.report_error err;
67
      raise exc
68
  in
14

  
15
open Utils
16
open LustreSpec
17
open Compiler_common
18
 
19
exception StopPhase1 of program
20

  
21
let usage = "Usage: lustrem [options] \x1b[4msource file\x1b[0m"
22

  
23
let extensions = [".ec"; ".lus"; ".lusi"]
24

  
25

  
26

  
27
(* From prog to prog *)
28
let stage1 prog dirname basename =
29
  (* Removing automata *) 
30
  let prog = expand_automata prog in
31

  
32
  Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@.@[<v 2>@ %a@]@," Printers.pp_prog prog);
33

  
34
  (* Importing source *)
35
  let _ = Modules.load_program ISet.empty prog in
69 36

  
70 37
  (* Extracting dependencies *)
71
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
72
  let dependencies = 
73
    List.fold_right 
74
      (fun d accu -> match d.Corelang.top_decl_desc with 
75
      | Corelang.Open s -> s::accu 
76
      | _ -> accu) 
77
      prog [] 
78
  in
79
  let type_env, clock_env =
80
    List.fold_left (fun (type_env, clock_env) s -> 
81
      try
82
	let basename = s ^ ".lusi" in 
83
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
84
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
85
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
86
	Env.overwrite type_env lusi_type_env,
87
	Env.overwrite clock_env lusi_clock_env      
88
      with Sys_error msg -> (
89
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
90
	exit 1
91
      )
92
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
93
  in
94
  
38
  let dependencies, type_env, clock_env = import_dependencies prog in
39

  
95 40
  (* Sorting nodes *)
96 41
  let prog = SortProg.sort prog in
97
  
42

  
43
  (* Perform inlining before any analysis *)
44
  let orig, prog =
45
    if !Options.global_inline && !Options.main_node <> "" then
46
      (if !Options.witnesses then prog else []),
47
      Inliner.global_inline basename prog type_env clock_env
48
    else (* if !Option.has_local_inline *)
49
      [],
50
      Inliner.local_inline basename prog type_env clock_env
51
  in
52

  
53
  (* Checking stateless/stateful status *)
54
  if Scopes.Plugin.is_active () then
55
    force_stateful_decls prog
56
  else
57
    check_stateless_decls prog;
58

  
98 59
  (* Typing *)
99 60
  let computed_types_env = type_decls type_env prog in
100
  
61

  
101 62
  (* Clock calculus *)
102 63
  let computed_clocks_env = clock_decls clock_env prog in
103 64

  
......
119 80
    let mutant_filename = 
120 81
      match !Options.dest_dir with
121 82
      | "" -> (* Mutants are generated in source directory *)
122
	basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
83
	basename^ ".mutant.n" ^ (string_of_int !cpt) ^ ".lus" 
123 84
      | dir ->  (* Mutants are generated in targer directory *)
124
	dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
85
	dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ ".lus"
125 86
    in
126 87
    let mutant_out = (
127 88
      try 
......
135 96
    Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant    
136 97
  )
137 98
    mutants;
99
  exit 0
100
  
101
let mutate dirname basename extension =
102
  (* Loading the input file *)
103
  let source_name = dirname ^ "/" ^ basename ^ extension in
138 104

  
139
  (*
140

  
141

  
142
  (* Normalization phase *)
143
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
144
  let normalized_prog = Normalization.normalize_prog prog in
145
  Typing.uneval_prog_generics normalized_prog;
146
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
147
  (* Checking array accesses *)
148
  if !Options.check then
149
    begin
150
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,@?");
151
      Access.check_prog normalized_prog;
152
    end;
153

  
154
  (* DFS with modular code generation *)
155
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,@?");
156
  let machine_code = Machine_code.translate_prog normalized_prog in
157
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
158
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
159
    machine_code);
160

  
161
  (* Checking the existence of a lusi (Lustre Interface file) *)
162
  let lusi_name = basename ^ ".lusi" in
163
  let _ = 
164
    try 
165
      let _ = open_in lusi_name in
166
      let _, declared_types_env, declared_clocks_env = load_lusi lusi_name in
167
      (* checking type compatibilty with computed types*)
168
      Typing.check_env_compat declared_types_env computed_types_env;
169
      (* checking clocks compatibilty with computed clocks*)
170
      Clock_calculus.check_env_compat declared_clocks_env computed_clocks_env;
171
      
172
    with Sys_error _ -> ( 
173
      (* Printing lusi file is necessary *)
174
      report ~level:1 
175
	(fun fmt -> 
176
	  fprintf fmt 
177
	    ".. generating lustre interface file %s@,@?" lusi_name);
178
      let lusi_out = open_out lusi_name in
179
      let lusi_fmt = formatter_of_out_channel lusi_out in
180
      Printers.pp_lusi_header lusi_fmt source_name normalized_prog
181
    )
182
    | (Types.Error (loc,err)) as exc ->
183
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
184
	Types.pp_error err;
185
      raise exc
186
  in
105
  Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
106

  
107
   (* Parsing source *)
108
  let prog = parse_source source_name in
109
  stage1 prog dirname basename
187 110

  
188
  (* Printing code *)
189
  let basename    = Filename.basename basename in
190
  if !Options.java then
191
    failwith "Sorry, but not yet supported !"
192
    (*let source_file = basename ^ ".java" in
193
      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
194
      let source_out = open_out source_file in
195
      let source_fmt = formatter_of_out_channel source_out in
196
      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
197
      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
198
  else begin
199
    let header_file = basename ^ ".h" in (* Could be changed *)
200
    let source_file = basename ^ ".c" in (* Could be changed *)
201
    let makefile_file = basename ^ ".makefile" in (* Could be changed *)
202
    let spec_file_opt = if !Options.c_spec then 
203
	(
204
	  let spec_file = basename ^ "_spec.c" in
205
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@,@?" header_file source_file spec_file);
206
	  Some spec_file 
207
	) else (
208
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@,@?" header_file source_file);
209
	  None 
210
	 )
211
    in 
212
    let header_out = open_out header_file in
213
    let header_fmt = formatter_of_out_channel header_out in
214
    let source_out = open_out source_file in
215
    let source_fmt = formatter_of_out_channel source_out in
216
    let makefile_out = open_out makefile_file in
217
    let makefile_fmt = formatter_of_out_channel makefile_out in
218
    let spec_fmt_opt = match spec_file_opt with
219
	None -> None
220
      | Some f -> Some (formatter_of_out_channel (open_out f))
221
    in
222
    report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
223
    C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code;
224
  end;
225
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
226
  (* We stop the process here *)
227
  *)
228
  exit 0
229 111
  
230 112
let anonymous filename =
231
  let ok_ext, ext = List.fold_left (fun (ok, ext) ext' -> if not ok && Filename.check_suffix filename ext' then true, ext' else ok, ext) (false, "") extensions in
113
  let ok_ext, ext = List.fold_left
114
    (fun (ok, ext) ext' ->
115
      if not ok && Filename.check_suffix filename ext' then
116
	true, ext'
117
      else
118
	ok, ext)
119
    (false, "") extensions in
232 120
  if ok_ext then
233
    let basename = Filename.chop_suffix filename ext in
234
    mutate basename ext
121
    let dirname = Filename.dirname filename in
122
    let basename = Filename.chop_suffix (Filename.basename filename) ext in
123
    mutate dirname basename ext
235 124
  else
236 125
    raise (Arg.Bad ("Can only compile *.lus or *.ec files"))
237 126

  
238 127
let _ =
128
  Global.initialize ();
239 129
  Corelang.add_internal_funs ();
240 130
  try
241 131
    Printexc.record_backtrace true;
242
    Arg.parse Options.lustrem_options anonymous usage
132

  
133
    let options = Options.options @ 
134
      List.flatten (
135
	List.map Options.plugin_opt [
136
	  Scopes.Plugin.name, Scopes.Plugin.activate, Scopes.Plugin.options
137
	]
138
      )
139
    in
140
    
141
    Arg.parse options anonymous usage
243 142
  with
244
  | Parse.Syntax_err _ | Lexer_lustre.Error _ 
143
  | Parse.Error _
245 144
  | Types.Error (_,_) | Clocks.Error (_,_)
246
  | Corelang.Error _ (*| Task_set.Error _*) 
247
  | Causality.Cycle _ -> exit 1
145
  | Corelang.Error _ (*| Task_set.Error _*)
146
  | Causality.Error _ -> exit 1
147
  | Sys_error msg -> (eprintf "Failure: %s@." msg)
248 148
  | exc -> (Utils.track_exception (); raise exc)
249 149

  
250 150
(* Local Variables: *)
src/mutation.ml
1 1
open Corelang
2
open LustreSpec
2 3
open Log
3 4
open Format
4 5

  
......
102 103

  
103 104
let compute_records_eq eq = compute_records_expr eq.eq_rhs
104 105

  
106
let compute_records_stmt s =
107
  match s with
108
  | Eq eq -> compute_records_expr eq.eq_rhs
109
  | _ -> empty_records (* Automata should have been desintegrate by now *)
110

  
105 111
let compute_records_node nd = 
106
  merge_records (List.map compute_records_eq nd.node_eqs)
112
  merge_records (List.map compute_records_stmt nd.node_stmts)
107 113

  
108 114
let compute_records_top_decl td =
109 115
  match td.top_decl_desc with
110 116
  | Node nd -> compute_records_node nd
111
  | Consts constsl -> merge_records (List.map (fun c -> compute_records_const_value c.const_value) constsl)
117
  | Const const -> compute_records_const_value const.const_value
112 118
  | _ -> empty_records
113 119

  
114 120
let compute_records prog = 
......
188 194
let rdm_mutate_const_value c =
189 195
  match c with
190 196
  | Const_int i -> Const_int (rdm_mutate_int i)
191
  | Const_real s ->  Const_real s (* those are string, let's leave them *)
192
  | Const_float f -> Const_float (rdm_mutate_float f)
197
  | Const_real (num, npow, s) as c ->  c
198
  (* OTOD: mutation disable here, should look at rdm_mutate_float f and adapt it *)
193 199
  | Const_array _
194
  | Const_tag _ -> c
200
  | Const_tag _
201
  | Const_string _
202
  |Const_struct _  -> c
195 203

  
196 204
let rdm_mutate_const c =
197 205
  let new_const = rdm_mutate_const_value c.const_value in
......
268 276
  mutation, { eq with eq_rhs = new_rhs }
269 277

  
270 278
let rdm_mutate_node nd = 
271
  let mutation, new_node_eqs =       
279
  let mutation, new_node_stmts =
272 280
    select_in_list 
273
      nd.node_eqs 
274
      (fun eq -> let mut, new_eq = rdm_mutate_eq eq in
275
		 report ~level:1 
276
		   (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
277
		     Printers.pp_node_eq eq
278
		     Printers.pp_node_eq new_eq);
279
		 mut, new_eq )
281
      nd.node_stmts 
282
      (fun stmt ->match stmt with
283
      | Eq eq -> let mut, new_eq = rdm_mutate_eq eq in
284
		  report ~level:1 
285
		    (fun fmt -> fprintf fmt "mutation: %a becomes %a@." 
286
		      Printers.pp_node_eq eq
287
		      Printers.pp_node_eq new_eq);
288
		  mut, Eq new_eq
289
      | _ -> assert false (* shold have been removed by now *) )
280 290
  in
281
  mutation, { nd with node_eqs = new_node_eqs }
291
  mutation, { nd with node_stmts = new_node_stmts }
282 292

  
283 293
let rdm_mutate_top_decl td =
284 294
  match td.top_decl_desc with
285 295
  | Node nd -> 
286 296
    let mutation, new_node = rdm_mutate_node nd in 
287 297
    mutation, { td with top_decl_desc = Node new_node}
288
  | Consts constsl -> 
289
    let mut, new_constsl = select_in_list constsl rdm_mutate_const in
290
    mut, { td with top_decl_desc = Consts new_constsl }
298
  | Const const -> 
299
    let mut, new_const = rdm_mutate_const const in
300
    mut, { td with top_decl_desc = Const new_const }
291 301
  | _ -> None, td
292 302
    
293 303
(* Create a single mutant with the provided random seed *)
......
474 484
let fold_mutate_eq eq =
475 485
  { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
476 486

  
487
let fold_mutate_stmt s =
488
  match s with
489
  | Eq eq -> Eq { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
490
  | _ -> assert false (* should have been removed by now *)
491

  
477 492
let fold_mutate_node nd = 
478 493
  { nd with 
479
    node_eqs = 
480
      List.fold_right (fun e res -> (fold_mutate_eq e)::res) nd.node_eqs [];
494
    node_stmts = 
495
      List.fold_right (fun e res -> (fold_mutate_stmt e)::res) nd.node_stmts [];
481 496
    node_id = rename_app nd.node_id
482 497
  }
483 498

  
484 499
let fold_mutate_top_decl td =
485 500
  match td.top_decl_desc with
486 501
  | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)}
487
  | Consts constsl -> { td with top_decl_desc = Consts (List.fold_right (fun e res -> (fold_mutate_const e)::res) constsl [])}
502
  | Const const -> { td with top_decl_desc = Const (fold_mutate_const const)}
488 503
  | _ -> td
489 504
    
490 505
(* Create a single mutant with the provided random seed *)
src/pathConditions.ml
133 133
  | _::_, Types.Ttuple tl, Expr_tuple rhs -> List.iter2 mcdc_var_def eq.eq_lhs rhs
134 134
  | _ -> mcdc_expr 0 eq.eq_rhs 
135 135

  
136
let mcdc_node_stmt s =
137
  match s with Eq eq -> mcdc_node_eq eq | _ -> assert false (* should have been removed by now *)
138
    
136 139
let mcdc_top_decl td = 
137 140
  match td.top_decl_desc with
138
  | Node nd -> List.iter mcdc_node_eq nd.node_eqs
141
  | Node nd -> List.iter mcdc_node_stmt nd.node_stmts
139 142
  | _ -> ()
140 143

  
141 144

  

Also available in: Unified diff