1
|
(********************************************************************)
|
2
|
(* *)
|
3
|
(* The LustreC compiler toolset / The LustreC Development Team *)
|
4
|
(* Copyright 2012 - -- ONERA - CNRS - INPT *)
|
5
|
(* *)
|
6
|
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
|
7
|
(* under the terms of the GNU Lesser General Public License *)
|
8
|
(* version 2.1. *)
|
9
|
(* *)
|
10
|
(********************************************************************)
|
11
|
|
12
|
open Utils
|
13
|
open Format
|
14
|
open Lustre_types
|
15
|
open Corelang
|
16
|
|
17
|
let check_main () =
|
18
|
if !Options.main_node = "" then
|
19
|
begin
|
20
|
eprintf "Code generation error: %a@." Error.pp_error_msg Error.No_main_specified;
|
21
|
raise (Error (Location.dummy_loc, Error.No_main_specified))
|
22
|
end
|
23
|
|
24
|
let create_dest_dir () =
|
25
|
begin
|
26
|
if not (Sys.file_exists !Options.dest_dir) then
|
27
|
begin
|
28
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@ ");
|
29
|
Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
|
30
|
end;
|
31
|
if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
|
32
|
begin
|
33
|
eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
|
34
|
exit 1
|
35
|
end
|
36
|
end
|
37
|
|
38
|
(* Loading Lusi file and filling type tables with parsed
|
39
|
functions/nodes *)
|
40
|
let parse_header own filename =
|
41
|
Location.set_input filename;
|
42
|
let h_in = open_in filename in
|
43
|
let lexbuf = Lexing.from_channel h_in in
|
44
|
Location.init lexbuf filename;
|
45
|
(* Parsing *)
|
46
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
|
47
|
try
|
48
|
let header = Parse.header Parser_lustre.header Lexer_lustre.token lexbuf in
|
49
|
(*ignore (Modules.load_header ISet.empty header);*)
|
50
|
close_in h_in;
|
51
|
header
|
52
|
with
|
53
|
| (Parse.Error err) as exc ->
|
54
|
Parse.report_error err;
|
55
|
raise exc
|
56
|
| Corelang.Error (loc, err) as exc -> (
|
57
|
eprintf "Parsing error: %a%a@."
|
58
|
Error.pp_error_msg err
|
59
|
Location.pp_loc loc;
|
60
|
raise exc
|
61
|
)
|
62
|
|
63
|
let parse_source source_name =
|
64
|
(* Loading the input file *)
|
65
|
Location.set_input source_name;
|
66
|
let s_in = open_in source_name in
|
67
|
let lexbuf = Lexing.from_channel s_in in
|
68
|
Location.init lexbuf source_name;
|
69
|
|
70
|
(* Parsing *)
|
71
|
Log.report ~level:1
|
72
|
(fun fmt -> fprintf fmt ".. parsing source file %s@ " source_name);
|
73
|
try
|
74
|
let prog = Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf in
|
75
|
(*ignore (Modules.load_program ISet.empty prog);*)
|
76
|
close_in s_in;
|
77
|
prog
|
78
|
with
|
79
|
| (Parse.Error err) as exc ->
|
80
|
Parse.report_error err;
|
81
|
raise exc
|
82
|
| Corelang.Error (loc, err) as exc ->
|
83
|
eprintf "Parsing error: %a%a@."
|
84
|
Error.pp_error_msg err
|
85
|
Location.pp_loc loc;
|
86
|
raise exc
|
87
|
|
88
|
let expand_automata decls =
|
89
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. expanding automata@ ");
|
90
|
try
|
91
|
Automata.expand_decls decls
|
92
|
with (Corelang.Error (loc, err)) as exc ->
|
93
|
eprintf "Automata error: %a%a@."
|
94
|
Error.pp_error_msg err
|
95
|
Location.pp_loc loc;
|
96
|
raise exc
|
97
|
|
98
|
let check_stateless_decls decls =
|
99
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@ ");
|
100
|
try
|
101
|
Stateless.check_prog decls
|
102
|
with (Stateless.Error (loc, err)) as exc ->
|
103
|
eprintf "Stateless status error: %a%a@."
|
104
|
Stateless.pp_error err
|
105
|
Location.pp_loc loc;
|
106
|
raise exc
|
107
|
|
108
|
let force_stateful_decls decls =
|
109
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. forcing stateful status@ ");
|
110
|
try
|
111
|
Stateless.force_prog decls
|
112
|
with (Stateless.Error (loc, err)) as exc ->
|
113
|
eprintf "Stateless status error: %a%a@."
|
114
|
Stateless.pp_error err
|
115
|
Location.pp_loc loc;
|
116
|
raise exc
|
117
|
|
118
|
let type_decls env decls =
|
119
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. typing@ ");
|
120
|
let new_env =
|
121
|
begin
|
122
|
try
|
123
|
Typing.type_prog env decls
|
124
|
with (Types.Error (loc,err)) as exc ->
|
125
|
eprintf "Typing error: %a%a@."
|
126
|
Types.pp_error err
|
127
|
Location.pp_loc loc;
|
128
|
raise exc
|
129
|
end
|
130
|
in
|
131
|
if !Options.print_types || !Options.verbose_level > 2 then
|
132
|
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_type decls);
|
133
|
new_env
|
134
|
|
135
|
let clock_decls env decls =
|
136
|
Log.report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@ ");
|
137
|
let new_env =
|
138
|
begin
|
139
|
try
|
140
|
Clock_calculus.clock_prog env decls
|
141
|
with (Clocks.Error (loc,err)) as exc ->
|
142
|
eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc loc;
|
143
|
raise exc
|
144
|
end
|
145
|
in
|
146
|
if !Options.print_clocks || !Options.verbose_level > 2 then
|
147
|
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2> %a@]@ " Corelang.pp_prog_clock decls);
|
148
|
new_env
|
149
|
|
150
|
let check_top_decls header =
|
151
|
let new_tenv = type_decls Basic_library.type_env header in (* Typing *)
|
152
|
let new_cenv = clock_decls Basic_library.clock_env header in (* Clock calculus *)
|
153
|
header, new_tenv, new_cenv
|
154
|
|
155
|
let get_envs_from_const const_decl (ty_env, ck_env) =
|
156
|
(Env.add_value ty_env const_decl.const_id const_decl.const_type,
|
157
|
Env.add_value ck_env const_decl.const_id (Clocks.new_var true))
|
158
|
|
159
|
let get_envs_from_consts const_decls (ty_env, ck_env) =
|
160
|
List.fold_right get_envs_from_const const_decls (ty_env, ck_env)
|
161
|
|
162
|
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
|
163
|
match top_decl.top_decl_desc with
|
164
|
| Node nd -> (Env.add_value ty_env nd.node_id nd.node_type,
|
165
|
Env.add_value ck_env nd.node_id nd.node_clock)
|
166
|
| ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
|
167
|
Env.add_value ck_env ind.nodei_id ind.nodei_clock)
|
168
|
| Const c -> get_envs_from_const c (ty_env, ck_env)
|
169
|
| TypeDef _ -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)
|
170
|
| Open _ -> (ty_env, ck_env)
|
171
|
|
172
|
(* get type and clock environments from a header *)
|
173
|
let get_envs_from_top_decls header =
|
174
|
List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
|
175
|
|
176
|
(*
|
177
|
List.fold_right
|
178
|
(fun top_decl (ty_env, ck_env) ->
|
179
|
match top_decl.top_decl_desc with
|
180
|
| Node nd -> (Env.add_value ty_env nd.node_id nd.node_type,
|
181
|
Env.add_value ck_env nd.node_id nd.node_clock)
|
182
|
| ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
|
183
|
Env.add_value ck_env ind.nodei_id ind.nodei_clock)
|
184
|
| Const c -> get_envs_from_const c (ty_env, ck_env)
|
185
|
| TypeDef _ -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
|
186
|
| Open _ -> (ty_env, ck_env))
|
187
|
header
|
188
|
(Env.initial, Env.initial)
|
189
|
*)
|
190
|
|
191
|
let generate_lusic_header destname lusic_ext =
|
192
|
match !Options.output with
|
193
|
| "C" -> C_backend_lusic.print_lusic_to_h destname lusic_ext
|
194
|
| _ -> ()
|
195
|
|
196
|
|
197
|
|
198
|
let check_compatibility (prog, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
|
199
|
try
|
200
|
(* checking defined types are compatible with declared types*)
|
201
|
Typing.check_typedef_compat header;
|
202
|
|
203
|
(* checking type compatibility with computed types*)
|
204
|
Typing.check_env_compat header declared_types_env computed_types_env;
|
205
|
|
206
|
(* checking clocks compatibility with computed clocks*)
|
207
|
Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
|
208
|
|
209
|
(* checking stateless status compatibility *)
|
210
|
Stateless.check_compat header
|
211
|
with
|
212
|
| (Types.Error (loc,err)) as exc ->
|
213
|
eprintf "Type mismatch between computed type and declared type in lustre interface file: %a%a@."
|
214
|
Types.pp_error err
|
215
|
Location.pp_loc loc;
|
216
|
raise exc
|
217
|
| Clocks.Error (loc, err) as exc ->
|
218
|
eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a%a@."
|
219
|
Clocks.pp_error err
|
220
|
Location.pp_loc loc;
|
221
|
raise exc
|
222
|
| Stateless.Error (loc, err) as exc ->
|
223
|
eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a%a@."
|
224
|
Stateless.pp_error err
|
225
|
Location.pp_loc loc;
|
226
|
raise exc
|
227
|
|
228
|
let is_stateful topdecl =
|
229
|
match topdecl.top_decl_desc with
|
230
|
| Node nd -> (match nd.node_stateless with Some b -> not b | None -> not nd.node_dec_stateless)
|
231
|
| ImportedNode nd -> not nd.nodei_stateless
|
232
|
| _ -> false
|
233
|
|
234
|
|
235
|
let rec import_dependencies prog =
|
236
|
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 4>.. extracting dependencies");
|
237
|
let dependencies = Corelang.get_dependencies prog in
|
238
|
let deps =
|
239
|
List.fold_left
|
240
|
(fun (compilation_dep, type_env, clock_env) dep ->
|
241
|
let (local, s) = Corelang.dependency_of_top dep in
|
242
|
let basename = Options_management.name_dependency (local, s) in
|
243
|
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ Library %s@ " basename);
|
244
|
let lusic = Modules.import_dependency dep.top_decl_loc (local, s) in
|
245
|
(*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "");*)
|
246
|
let lusic_deps, type_env', clock_env' = import_dependencies lusic.Lusic.contents in
|
247
|
let type_env = Env.overwrite type_env type_env' in
|
248
|
let clock_env = Env.overwrite clock_env clock_env' in
|
249
|
let (lusi_type_env, lusi_clock_env) = get_envs_from_top_decls lusic.Lusic.contents in
|
250
|
let is_stateful = List.exists is_stateful lusic.Lusic.contents in
|
251
|
let new_dep = Dep (local, s, lusic.Lusic.contents, is_stateful ) in
|
252
|
new_dep::lusic_deps@compilation_dep,
|
253
|
Env.overwrite type_env lusi_type_env,
|
254
|
Env.overwrite clock_env lusi_clock_env)
|
255
|
([], Basic_library.type_env, Basic_library.clock_env)
|
256
|
dependencies in
|
257
|
begin
|
258
|
Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
|
259
|
deps
|
260
|
end
|
261
|
|
262
|
let track_exception () =
|
263
|
if !Options.track_exceptions
|
264
|
then (Printexc.print_backtrace stdout; flush stdout)
|
265
|
else ()
|
266
|
|
267
|
|
268
|
let update_vdecl_parents_prog prog =
|
269
|
let update_vdecl_parents parent v =
|
270
|
v.var_parent_nodeid <- Some parent
|
271
|
in
|
272
|
List.iter (
|
273
|
fun top -> match top.top_decl_desc with
|
274
|
| Node nd ->
|
275
|
List.iter
|
276
|
(update_vdecl_parents nd.node_id)
|
277
|
(nd.node_inputs @ nd.node_outputs @ nd.node_locals )
|
278
|
| ImportedNode ind ->
|
279
|
List.iter
|
280
|
(update_vdecl_parents ind.nodei_id)
|
281
|
(ind.nodei_inputs @ ind.nodei_outputs )
|
282
|
| _ -> ()
|
283
|
) prog
|