Project

General

Profile

Revision 17abbe95 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
    
87 33
let rec compile basename extension =
88
  (* Loading the input file *)
89 34
  let source_name = basename^extension in
90 35
  Location.input_name := source_name;
91 36
  let lexbuf = Lexing.from_channel (open_in source_name) in
92 37
  Location.init lexbuf source_name;
93 38
  (* Parsing *)
94
  report ~level:1 
95
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
39
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
96 40
  let prog =
97 41
    try
98 42
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
......
100 44
      Parse.report_error err;
101 45
      raise exc
102 46
  in
103
  (* Extracting dependencies *)
104
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
105
  let dependencies = 
47
  (* Extract includes *)
48
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting includes@,@?");
49
  let includes = 
106 50
    List.fold_right 
107
      (fun d accu -> match d.Corelang.top_decl_desc with 
108
      | Corelang.Open s -> s::accu 
109
      | _ -> accu) 
51
      (fun d accu -> match d.Corelang.top_decl_desc with | Corelang.Include s -> s::accu | _ -> accu) 
110 52
      prog [] 
111 53
  in
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
  
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;
128 60
  (* Unfold consts *)
129 61
  (*let prog = Corelang.prog_unfold_consts prog in*)
130 62

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

  
134 66
  (* Typing *)
135
  let computed_types_env = type_decls type_env prog in
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);
136 80
  
137 81
  (* Clock calculus *)
138
  let computed_clocks_env = clock_decls clock_env prog in
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);
139 93

  
140 94
  (* Delay calculus *)
141
  (*
142
    if(!Options.delay_calculus)
143
    then
95
(*
96
  if(!Options.delay_calculus)
97
  then
144 98
    begin
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
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
153 107
    end;
154
  *)
108
*)
155 109
  (*
156 110
    eprintf "Causality analysis@.@?";
157
    (* Causality analysis *)
111
  (* Causality analysis *)
158 112
    begin
159 113
    try
160 114
    Causality.check_causal_prog prog
......
185 139
  let machine_code = Machine_code.translate_prog normalized_prog in
186 140
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
187 141
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
188
    machine_code);
189 142

  
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
143
    machine_code);
216 144

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

Also available in: Unified diff