Project

General

Profile

Revision 54ae8ac7 src/main_lustre_compiler.ml

View differences:

src/main_lustre_compiler.ml
31 31
let extensions = [".ec"; ".lus"; ".lusi"]
32 32

  
33 33
let check_stateless_decls decls =
34
  report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@,@?");
34
  report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@ ");
35 35
  try
36 36
    Stateless.check_prog decls
37 37
  with (Stateless.Error (loc, err)) as exc ->
38
    Format.eprintf "Stateless status error at loc %a: %a@]@."
38
    Format.eprintf "Stateless status error at loc %a: %a@."
39 39
      Location.pp_loc loc
40 40
      Stateless.pp_error err;
41 41
    raise exc
42 42

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

  
76 76
(* Loading Lusi file and filling type tables with parsed
......
80 80
  let lexbuf = Lexing.from_channel (open_in filename) in
81 81
  Location.init lexbuf filename;
82 82
  (* Parsing *)
83
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
84
  try
85
    Parse.header own Parser_lustre.header Lexer_lustre.token lexbuf
86
  with
87
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
88
    Parse.report_error err;
89
    raise exc
90
  | Corelang.Error (loc, err) as exc ->
91
     Format.eprintf "Parsing error at loc %a: %a@]@."
92
       Location.pp_loc loc
83
  report ~level:1 (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
84
    try
85
      Parse.header own Parser_lustre.header Lexer_lustre.token lexbuf
86
    with
87
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
88
      Parse.report_error err;
89
      raise exc
90
    | Corelang.Error (loc, err) as exc -> (
91
      Format.eprintf "Parsing error at loc %a: %a@."
92
	Location.pp_loc loc
93 93
       Corelang.pp_error err;
94
     raise exc
94
      raise exc
95
    )
96

  
95 97

  
96 98
let check_lusi header =
97 99
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
98 100
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
99 101
  header, new_tenv, new_cenv
102

  
100 103
    
101 104
let rec compile basename extension =
102 105
  (* Loading the input file *)
......
106 109
  Location.init lexbuf source_name;
107 110
  (* Parsing *)
108 111
  report ~level:1 
109
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
112
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@," source_name);
110 113
  let prog =
111 114
    try
112 115
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
......
115 118
      Parse.report_error err;
116 119
      raise exc
117 120
    | Corelang.Error (loc, err) as exc ->
118
      Format.eprintf "Parsing error at loc %a: %a@]@."
121
      Format.eprintf "Parsing error at loc %a: %a@."
119 122
	Location.pp_loc loc
120 123
	Corelang.pp_error err;
121 124
      raise exc
122 125
  in
123 126
  (* Extracting dependencies *)
124
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
127
  report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting dependencies@,");
125 128
  let dependencies = 
126 129
    List.fold_right 
127 130
      (fun d accu -> match d.Corelang.top_decl_desc with 
128
      | Corelang.Open s -> s::accu 
131
      | Corelang.Open (local, s) -> (s, local)::accu 
129 132
      | _ -> accu) 
130 133
      prog [] 
131 134
  in
132
  let type_env, clock_env =
133
    List.fold_left (fun (type_env, clock_env) s -> 
135
  let dependencies, type_env, clock_env =
136
    List.fold_left (fun (compilation_dep, type_env, clock_env) (s, local) -> 
134 137
      try
135
	let basename = s ^ ".lusi" in 
136
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
137
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
138
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
138
	let basename = (if local then s else Version.prefix ^ "/include/lustrec/" ^ s ) ^ ".lusi" in 
139
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 0>Library %s@," basename);
140
	let comp_dep, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
141
	report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
142
	(s, local, comp_dep)::compilation_dep,
139 143
	Env.overwrite type_env lusi_type_env,
140 144
	Env.overwrite clock_env lusi_clock_env      
141 145
      with Sys_error msg -> (
142 146
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
143 147
	exit 1
144 148
      )
145
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
149
    )  ([], Basic_library.type_env, Basic_library.clock_env) dependencies
146 150
  in
151
  report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
147 152
  
148 153
  (* Unfold consts *)
149 154
  (*let prog = Corelang.prog_unfold_consts prog in*)
......
216 221
      report ~level:1 
217 222
	(fun fmt -> 
218 223
	  fprintf fmt 
219
	    ".. generating lustre interface file %s@,@?" lusi_name);
224
	    ".. generating lustre interface file %s@," lusi_name);
220 225
      let lusi_out = open_out lusi_name in
221 226
      let lusi_fmt = formatter_of_out_channel lusi_out in
222 227
      Typing.uneval_prog_generics prog;
......
224 229
      Printers.pp_lusi_header lusi_fmt source_name prog
225 230
    )
226 231
    | (Types.Error (loc,err)) as exc ->
227
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
232
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@."
228 233
	Types.pp_error err;
229 234
      raise exc
230 235
    | Clocks.Error (loc, err) as exc ->
231
      Format.eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@]@."
236
      Format.eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@."
232 237
	Clocks.pp_error err;
233 238
      raise exc
234 239
    | Stateless.Error (loc, err) as exc ->
235
      Format.eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@]@."
240
      Format.eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@."
236 241
	Stateless.pp_error err;
237 242
      raise exc
238 243
  in
......
243 248
  (*Hashtbl.iter (fun id td -> match td.Corelang.top_decl_desc with Corelang.Node nd -> Format.eprintf "%s calls %a" id Causality.NodeDep.pp_generic_calls nd | _ -> ()) Corelang.node_table;*)
244 249

  
245 250
  (* Normalization phase *)
246
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
251
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,");
247 252
  let normalized_prog = Normalization.normalize_prog prog in
248
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
253
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog normalized_prog);
249 254
  (* Checking array accesses *)
250 255
  if !Options.check then
251 256
    begin
252
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,@?");
257
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,");
253 258
      Access.check_prog normalized_prog;
254 259
    end;
255 260

  
256 261
  (* DFS with modular code generation *)
257
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,@?");
262
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,");
258 263
  let machine_code = Machine_code.translate_prog normalized_prog in
259
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
264
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
260 265
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
261 266
    machine_code);
262 267
  
263 268
  (* Creating destination directory if needed *)
264 269
  if not (Sys.file_exists !Options.dest_dir) then (
265
    report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,@?");
270
    report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,");
266 271
    Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
267 272
  );
268 273
  if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then (
......
281 286
	  let spec_file_opt = if !Options.c_spec then 
282 287
	      (
283 288
		let spec_file = basename ^ "_spec.c" in
284
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@,@?" header_file source_file spec_file);
289
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@," header_file source_file spec_file);
285 290
		Some spec_file 
286 291
	      ) else (
287
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@,@?" header_file source_file);
292
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@," header_file source_file);
288 293
		None 
289 294
	       )
290 295
	  in 
......
298 303
	      None -> None
299 304
	    | Some f -> Some (formatter_of_out_channel (open_out f))
300 305
	  in
301
	  report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
306
	  report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
302 307
	  C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code dependencies
303 308
	end
304 309
    | "java" ->

Also available in: Unified diff