Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / main_lustre_testgen.ml @ 3e1d20e0

History | View | Annotate | Download (5.2 KB)

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
(********************************************************************)
11

    
12
(* This module is used for the lustre test generator *)
13

    
14
open Format
15
open Log
16

    
17
open Utils
18
open LustreSpec
19
open Compiler_common
20

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

    
23
let extensions = [".lus"]
24

    
25
let pp_trace trace_filename mutation_list = 
26
  let trace_file = open_out trace_filename in
27
  let trace_fmt = formatter_of_out_channel trace_file in
28
  Format.fprintf trace_fmt "@[<v 2>{@ %a@ }@]"
29
    (fprintf_list
30
       ~sep:",@ "
31
       (fun fmt (mutation, mutation_loc, mutant_name) ->
32
	 Format.fprintf fmt "\"%s\": { @[<v 0>%a,@ %a@ }@]" 
33
	   mutant_name
34
	   Mutation.print_directive_json mutation
35
	   Mutation.print_loc_json mutation_loc
36
       ))
37
    mutation_list;
38
  Format.fprintf trace_fmt "@.@?" 
39
  
40
  
41
let testgen_source dirname basename extension =
42
  let source_name = dirname ^ "/" ^ basename ^ extension in
43

    
44
  Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
45

    
46
  (* Parsing source *)
47
  let prog = parse_source source_name in
48

    
49
  let prog, dependencies = Compiler_stages.stage1 prog dirname basename in
50

    
51
  (* Two cases
52
     - generation of coverage conditions
53
     - generation of mutants: a number of mutated lustre files 
54
  *)
55
  
56
  if !Options.gen_mcdc then (
57
    let prog_mcdc = PathConditions.mcdc prog in
58
  let _, type_env, _ = import_dependencies prog_mcdc in
59

    
60
    let _ = type_decls type_env prog_mcdc in
61

    
62
    let destname = !Options.dest_dir ^ "/" ^ basename in
63
    let source_file = destname ^ ".mcdc.lus" in (* Could be changed *)
64
    let source_out = open_out source_file in
65
    let fmt = formatter_of_out_channel source_out in
66
    Printers.pp_prog fmt prog_mcdc;
67
    Format.fprintf fmt "@.@?";
68
    exit 0
69
  ) ;
70

    
71
  
72
  (* generate mutants *)
73
  let mutants = Mutation.mutate !Options.nb_mutants prog in
74
  
75
  (* Print generated mutants in target directory. *)
76
  let cpt = ref 0 in
77
  let mutation_list =
78
    List.map (fun (mutation, mutation_loc, mutant) ->
79
    (* Debugging code *)
80
    (* if List.mem !cpt [238;371;601;799;875;998] then *)
81
    (*   Format.eprintf "Mutant %i: %a -> %a" !cpt Printers.pp_expr orig_e Printers.pp_expr new_e  *)
82
    (* ; *)
83
      incr cpt;
84
      let mutant_basename = (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension  in
85
      let mutant_filename = 
86
	match !Options.dest_dir with
87
	| "" -> (* Mutants are generated in source directory *)
88
	   basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
89
      | dir ->  (* Mutants are generated in target directory *)
90
	 dir ^ "/" ^ mutant_basename 
91
    in
92
    let mutant_out = (
93
      try 
94
	open_out mutant_filename 
95
      with
96
	Sys_error _ -> Format.eprintf "Unable to open file %s for writing.@." mutant_filename; exit 1
97
    )
98
    in
99
    let mutant_fmt = formatter_of_out_channel mutant_out in
100
    report ~level:1 (fun fmt -> fprintf fmt ".. generating mutant %s: %a@,@?"
101
      mutant_filename
102
      Mutation.print_directive mutation
103
    );
104
    Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant;
105
    mutation, mutation_loc, mutant_basename
106
    )
107
      mutants
108
  in
109
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. done @ @]@.");
110
  
111
  (* Printing traceability *)
112
  let trace_filename = 
113
    match !Options.dest_dir with
114
    | "" -> (* Mutant report is generated in source directory *)
115
       basename^ ".mutation.json" 
116
    | dir ->  (* Mutants are generated in target directory *)
117
       dir ^ "/" ^ (Filename.basename basename)^ ".mutation.json"
118
  in
119
  pp_trace trace_filename mutation_list;
120
  (* We stop the process here *)
121
  exit 0
122
    
123
let testgen dirname basename extension =
124
  match extension with
125
  | ".lus"   -> testgen_source dirname basename extension
126
  | _        -> assert false
127

    
128
let anonymous filename =
129
  let ok_ext, ext = List.fold_left
130
    (fun (ok, ext) ext' ->
131
      if not ok && Filename.check_suffix filename ext' then
132
	true, ext'
133
      else
134
	ok, ext)
135
    (false, "") extensions in
136
  if ok_ext then
137
    let dirname = Filename.dirname filename in
138
    let basename = Filename.chop_suffix (Filename.basename filename) ext in
139
    testgen dirname basename ext
140
  else
141
    raise (Arg.Bad ("Can only compile *.lus files"))
142

    
143
let _ =
144
  Global.initialize ();
145
  Corelang.add_internal_funs ();
146
  try
147
    Printexc.record_backtrace true;
148

    
149
    let options = Options_management.lustret_options
150

    
151
    in
152
    
153
    Arg.parse options anonymous usage
154
  with
155
  | Parse.Error _
156
  | Types.Error (_,_) | Clocks.Error (_,_)
157
  | Corelang.Error _ (*| Task_set.Error _*)
158
  | Causality.Error _ -> exit 1
159
  | Sys_error msg -> (eprintf "Failure: %s@." msg)
160
  | exc -> (track_exception (); raise exc)
161

    
162
(* Local Variables: *)
163
(* compile-command:"make -C .." *)
164
(* End: *)