Revision 5c1184ad src/main_lustre_compiler.ml
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