Project

General

Profile

Revision 5c1184ad src/main_lustre_compiler.ml

View differences:

src/main_lustre_compiler.ml
30 30

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

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

  
67
(* Loading Lusi file and filing type tables with parsed
68
   functions/nodes *)
69
let load_lusi filename =
70
  Location.input_name := filename;
71
  let lexbuf = Lexing.from_channel (open_in filename) in
72
  Location.init lexbuf filename;
73
  (* Parsing *)
74
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
75
  let header = 
76
    try
77
      Parse.prog Parser_lustre.header Lexer_lustre.token lexbuf
78
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
79
      Parse.report_error err;
80
      raise exc
81
  in
82
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
83
  let new_cenv: Clocks.clock_expr Utils.IMap.t = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
84
  header, new_tenv, new_cenv
85
  
86
    
33 87
let rec compile basename extension =
88
  (* Loading the input file *)
34 89
  let source_name = basename^extension in
35 90
  Location.input_name := source_name;
36 91
  let lexbuf = Lexing.from_channel (open_in source_name) in
37 92
  Location.init lexbuf source_name;
38 93
  (* Parsing *)
39
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
94
  report ~level:1 
95
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
40 96
  let prog =
41 97
    try
42 98
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
......
44 100
      Parse.report_error err;
45 101
      raise exc
46 102
  in
47
  (* Extract includes *)
48
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting includes@,@?");
49
  let includes = 
103
  (* Extracting dependencies *)
104
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
105
  let dependencies = 
50 106
    List.fold_right 
51
      (fun d accu -> match d.Corelang.top_decl_desc with | Corelang.Include s -> s::accu | _ -> accu) 
107
      (fun d accu -> match d.Corelang.top_decl_desc with 
108
      | Corelang.Open s -> s::accu 
109
      | _ -> accu) 
52 110
      prog [] 
53 111
  in
54
  List.iter (fun s -> let basename = Filename.chop_suffix s ".lus" in 
55
		      report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ ");
56
		      compile basename ".lus";
57
		      report ~level:1 (fun fmt -> fprintf fmt "@]@,@?")
58

  
59
  ) includes;
112
  let type_env, clock_env =
113
    List.fold_left (fun (type_env, clock_env) s -> 
114
      try
115
	let basename = s ^ ".lusi" in 
116
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
117
	let _, lusi_type_env, lusi_clock_env = load_lusi basename in 
118
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
119
	Env.overwrite type_env lusi_type_env,
120
	Env.overwrite clock_env lusi_clock_env      
121
      with Sys_error msg -> (
122
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
123
	exit 1
124
      )
125
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
126
  in
127
  
60 128
  (* Unfold consts *)
61 129
  (*let prog = Corelang.prog_unfold_consts prog in*)
62 130

  
63 131
  (* Sorting nodes *)
64 132
  let prog = SortProg.sort prog in
65

  
133
  
66 134
  (* Typing *)
67
  report ~level:1 (fun fmt -> fprintf fmt ".. typing@,@?");
68
  begin
69
    try
70
      Typing.type_prog Basic_library.type_env prog
71
      (*Typing.uneval_prog_generics prog*)
72
    with (Types.Error (loc,err)) as exc ->
73
      Format.eprintf "Typing error at loc %a: %a@]@."
74
      Location.pp_loc loc
75
      Types.pp_error err;
76
      raise exc
77
  end;
78
  if !Options.print_types then
79
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_type prog);
135
  let computed_types_env = type_decls type_env prog in
80 136
  
81 137
  (* Clock calculus *)
82
  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");
83
  begin
84
    try
85
      Clock_calculus.clock_prog Basic_library.clock_env prog
86
    with (Clocks.Error (loc,err)) as exc ->
87
      Location.print loc;
88
      eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;
89
      raise exc
90
  end;
91
  if !Options.print_clocks then
92
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock prog);
138
  let computed_clocks_env = clock_decls clock_env prog in
93 139

  
94 140
  (* Delay calculus *)
95
(*
96
  if(!Options.delay_calculus)
97
  then
141
  (*
142
    if(!Options.delay_calculus)
143
    then
98 144
    begin
99
      report ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?");
100
      try
101
	Delay_calculus.delay_prog Basic_library.delay_env prog
102
      with (Delay.Error (loc,err)) as exc ->
103
	Location.print loc;
104
	eprintf "%a" Delay.pp_error err;
105
	Utils.track_exception ();
106
	raise exc
145
    report ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?");
146
    try
147
    Delay_calculus.delay_prog Basic_library.delay_env prog
148
    with (Delay.Error (loc,err)) as exc ->
149
    Location.print loc;
150
    eprintf "%a" Delay.pp_error err;
151
    Utils.track_exception ();
152
    raise exc
107 153
    end;
108
*)
154
  *)
109 155
  (*
110 156
    eprintf "Causality analysis@.@?";
111
  (* Causality analysis *)
157
    (* Causality analysis *)
112 158
    begin
113 159
    try
114 160
    Causality.check_causal_prog prog
......
139 185
  let machine_code = Machine_code.translate_prog normalized_prog in
140 186
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
141 187
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
142

  
143 188
    machine_code);
144 189

  
190
  (* Checking the existence of a lusi (Lustre Interface file) *)
191
  let lusi_name = basename ^ ".lusi" in
192
  let _ = 
193
    try 
194
      let _ = open_in lusi_name in
195
      let _, declared_types_env, declared_clocks_env = load_lusi lusi_name in
196
      (* checking type compatibilty with computed types*)
197
      Typing.check_env_compat declared_types_env computed_types_env;
198
      (* checking clocks compatibilty with computed clocks*)
199
      Clock_calculus.check_env_compat declared_clocks_env computed_clocks_env;
200
      
201
    with Sys_error _ -> ( 
202
      (* Printing lusi file is necessary *)
203
      report ~level:1 
204
	(fun fmt -> 
205
	  fprintf fmt 
206
	    ".. generating lustre interface file %s@,@?" lusi_name);
207
      let lusi_out = open_out lusi_name in
208
      let lusi_fmt = formatter_of_out_channel lusi_out in
209
      Printers.pp_lusi_header lusi_fmt source_name normalized_prog
210
    )
211
    | (Types.Error (loc,err)) as exc ->
212
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
213
	Types.pp_error err;
214
      raise exc
215
  in
216

  
145 217
  (* Printing code *)
146 218
  let basename    = Filename.basename basename in
147 219
  if !Options.java then
148 220
    failwith "Sorry, but not yet supported !"
149 221
    (*let source_file = basename ^ ".java" in
150
    report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
151
    let source_out = open_out source_file in
152
    let source_fmt = formatter_of_out_channel source_out in
153
    report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
154
    Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
222
      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
223
      let source_out = open_out source_file in
224
      let source_fmt = formatter_of_out_channel source_out in
225
      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
226
      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
155 227
  else begin
156 228
    let header_file = basename ^ ".h" in (* Could be changed *)
157 229
    let source_file = basename ^ ".c" in (* Could be changed *)
230
    let makefile_file = basename ^ ".makefile" in (* Could be changed *)
158 231
    let spec_file_opt = if !Options.c_spec then 
159 232
	(
160 233
	  let spec_file = basename ^ "_spec.c" in
......
169 242
    let header_fmt = formatter_of_out_channel header_out in
170 243
    let source_out = open_out source_file in
171 244
    let source_fmt = formatter_of_out_channel source_out in
245
    let makefile_out = open_out makefile_file in
246
    let makefile_fmt = formatter_of_out_channel makefile_out in
172 247
    let spec_fmt_opt = match spec_file_opt with
173 248
	None -> None
174 249
      | Some f -> Some (formatter_of_out_channel (open_out f))
175 250
    in
176 251
    report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
177
    C_backend.translate_to_c header_fmt source_fmt spec_fmt_opt basename normalized_prog machine_code;
252
    C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code;
178 253
  end;
179 254
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
180 255
  (* We stop the process here *)

Also available in: Unified diff