Revision 17abbe95 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 |
|
|
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