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 Lustre_types
|
14
|
open Corelang
|
15
|
|
16
|
let name_dependency loc (local, dep) ext =
|
17
|
try Options_management.name_dependency (local, dep) ext
|
18
|
with Not_found ->
|
19
|
(* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s"
|
20
|
dep); *)
|
21
|
raise (Error.Error (loc, Error.Unknown_library dep))
|
22
|
|
23
|
(* let add_symbol loc msg hashtbl name value =
|
24
|
* if Hashtbl.mem hashtbl name
|
25
|
* then raise (Error.Error (loc, Error.Already_bound_symbol msg))
|
26
|
* else Hashtbl.add hashtbl name value *)
|
27
|
|
28
|
(* let check_symbol loc msg hashtbl name =
|
29
|
* if not (Hashtbl.mem hashtbl name)
|
30
|
* then raise (Error.Error (loc, Error.Unbound_symbol msg))
|
31
|
* else () *)
|
32
|
|
33
|
let add_imported_node name value =
|
34
|
(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name
|
35
|
Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
|
36
|
try
|
37
|
let value' = node_from_name name in
|
38
|
let owner' = value'.top_decl_owner in
|
39
|
let itf' = value'.top_decl_itf in
|
40
|
let owner = value.top_decl_owner in
|
41
|
let itf = value.top_decl_itf in
|
42
|
match value'.top_decl_desc, value.top_decl_desc with
|
43
|
| Node _, ImportedNode _ when owner = owner' && itf' && not itf ->
|
44
|
update_node name value
|
45
|
| ImportedNode _, ImportedNode _ ->
|
46
|
raise
|
47
|
(Error.Error
|
48
|
(value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
|
49
|
| _ ->
|
50
|
assert false
|
51
|
with Not_found -> update_node name value
|
52
|
|
53
|
let add_node name value =
|
54
|
(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node
|
55
|
(get_node_interface (node_of_top value)) value.top_decl_owner;*)
|
56
|
try
|
57
|
let value' = node_from_name name in
|
58
|
let owner' = value'.top_decl_owner in
|
59
|
let itf' = value'.top_decl_itf in
|
60
|
let owner = value.top_decl_owner in
|
61
|
let itf = value.top_decl_itf in
|
62
|
match value'.top_decl_desc, value.top_decl_desc with
|
63
|
| ImportedNode _, Node _ when owner = owner' && itf' && not itf ->
|
64
|
()
|
65
|
| Node _, Node _ ->
|
66
|
raise
|
67
|
(Error.Error
|
68
|
(value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
|
69
|
| _ ->
|
70
|
assert false
|
71
|
with Not_found -> update_node name value
|
72
|
|
73
|
let add_tag loc name typ =
|
74
|
if Hashtbl.mem tag_table name then
|
75
|
raise (Error.Error (loc, Error.Already_bound_symbol ("enum tag " ^ name)))
|
76
|
else Hashtbl.add tag_table name typ
|
77
|
|
78
|
let add_field loc name typ =
|
79
|
if Hashtbl.mem field_table name then
|
80
|
raise
|
81
|
(Error.Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
|
82
|
else Hashtbl.add field_table name typ
|
83
|
|
84
|
let import_typedef tydef =
|
85
|
let loc = tydef.top_decl_loc in
|
86
|
let rec import ty =
|
87
|
match ty with
|
88
|
| Tydec_enum tl ->
|
89
|
List.iter (fun tag -> add_tag loc tag tydef) tl
|
90
|
| Tydec_struct fl ->
|
91
|
List.iter
|
92
|
(fun (field, ty) ->
|
93
|
add_field loc field tydef;
|
94
|
import ty)
|
95
|
fl
|
96
|
| Tydec_clock ty ->
|
97
|
import ty
|
98
|
| Tydec_const c ->
|
99
|
if not (Hashtbl.mem type_table (Tydec_const c)) then
|
100
|
raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
|
101
|
else ()
|
102
|
| Tydec_array (_, ty) ->
|
103
|
import ty
|
104
|
| _ ->
|
105
|
()
|
106
|
in
|
107
|
import (typedef_of_top tydef).tydef_desc
|
108
|
|
109
|
let add_type _itf name value =
|
110
|
(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name
|
111
|
Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
|
112
|
try
|
113
|
let value' = Hashtbl.find type_table (Tydec_const name) in
|
114
|
let owner' = value'.top_decl_owner in
|
115
|
let itf' = value'.top_decl_itf in
|
116
|
let owner = value.top_decl_owner in
|
117
|
let itf = value.top_decl_itf in
|
118
|
match value'.top_decl_desc, value.top_decl_desc with
|
119
|
| TypeDef ty', TypeDef ty
|
120
|
when coretype_equal ty'.tydef_desc ty.tydef_desc
|
121
|
&& owner' = owner && itf' && not itf ->
|
122
|
()
|
123
|
| TypeDef _, TypeDef _ ->
|
124
|
raise
|
125
|
(Error.Error
|
126
|
(value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
|
127
|
| _ ->
|
128
|
assert false
|
129
|
with Not_found ->
|
130
|
import_typedef value;
|
131
|
Hashtbl.add type_table (Tydec_const name) value
|
132
|
|
133
|
(* let check_type loc name =
|
134
|
* if not (Hashtbl.mem type_table (Tydec_const name))
|
135
|
* then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ name)))
|
136
|
* else () *)
|
137
|
|
138
|
let add_const name value =
|
139
|
try
|
140
|
let value' = Hashtbl.find consts_table name in
|
141
|
let owner' = value'.top_decl_owner in
|
142
|
let itf' = value'.top_decl_itf in
|
143
|
let owner = value.top_decl_owner in
|
144
|
let itf = value.top_decl_itf in
|
145
|
match value'.top_decl_desc, value.top_decl_desc with
|
146
|
| Const c', Const c
|
147
|
when c.const_value = c'.const_value && owner' = owner && itf' && not itf
|
148
|
->
|
149
|
()
|
150
|
| Const _, Const _ ->
|
151
|
raise
|
152
|
(Error.Error
|
153
|
(value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
|
154
|
| _ ->
|
155
|
assert false
|
156
|
with Not_found -> Hashtbl.add consts_table name value
|
157
|
|
158
|
(* let import_dependency_aux loc (local, dep) =
|
159
|
* let basename = Options_management.name_dependency (local, dep) in
|
160
|
* let extension = ".lusic" in
|
161
|
* try
|
162
|
* let lusic = Lusic.read_lusic basename extension in
|
163
|
* Lusic.check_obsolete lusic basename;
|
164
|
* lusic
|
165
|
* with
|
166
|
* | Sys_error msg ->
|
167
|
* raise (Error (loc, Error.Unknown_library basename))
|
168
|
*
|
169
|
* let import_dependency loc (local, dep) =
|
170
|
* try
|
171
|
* import_dependency_aux loc (local, dep)
|
172
|
* with
|
173
|
* | Corelang.Error (_, err) as exc -> (
|
174
|
* Format.eprintf "Import error: %a%a@."
|
175
|
* Error.pp_error_msg err
|
176
|
* Location.pp_loc loc;
|
177
|
* raise exc
|
178
|
* ) *)
|
179
|
|
180
|
let get_lusic decl =
|
181
|
match decl.top_decl_desc with
|
182
|
| Open (local, dep) -> (
|
183
|
let loc = decl.top_decl_loc in
|
184
|
let extension = ".lusic" in
|
185
|
let basename = name_dependency loc (local, dep) extension in
|
186
|
try
|
187
|
let lusic = Lusic.read_lusic basename extension in
|
188
|
Lusic.check_obsolete lusic basename;
|
189
|
lusic
|
190
|
with Sys_error _ ->
|
191
|
raise (Error.Error (loc, Error.Unknown_library basename)))
|
192
|
| _ ->
|
193
|
assert false
|
194
|
(* should not happen *)
|
195
|
|
196
|
let get_envs_from_const const_decl (ty_env, ck_env) =
|
197
|
( Env.add_value ty_env const_decl.const_id const_decl.const_type,
|
198
|
Env.add_value ck_env const_decl.const_id (Clocks.new_var true) )
|
199
|
|
200
|
(* let get_envs_from_consts const_decls (ty_env, ck_env) =
|
201
|
* List.fold_right get_envs_from_const const_decls (ty_env, ck_env) *)
|
202
|
|
203
|
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
|
204
|
match top_decl.top_decl_desc with
|
205
|
| Node nd ->
|
206
|
( Env.add_value ty_env nd.node_id nd.node_type,
|
207
|
Env.add_value ck_env nd.node_id nd.node_clock )
|
208
|
| ImportedNode ind ->
|
209
|
( Env.add_value ty_env ind.nodei_id ind.nodei_type,
|
210
|
Env.add_value ck_env ind.nodei_id ind.nodei_clock )
|
211
|
| Const c ->
|
212
|
get_envs_from_const c (ty_env, ck_env)
|
213
|
| TypeDef _ ->
|
214
|
List.fold_left get_envs_from_top_decl (ty_env, ck_env)
|
215
|
(consts_of_enum_type top_decl)
|
216
|
| Include _ | Open _ ->
|
217
|
ty_env, ck_env
|
218
|
|
219
|
(* get type and clock environments from a header *)
|
220
|
let get_envs_from_top_decls header =
|
221
|
List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
|
222
|
|
223
|
let is_stateful topdecl =
|
224
|
match topdecl.top_decl_desc with
|
225
|
| Node nd -> (
|
226
|
match nd.node_stateless with
|
227
|
| Some b ->
|
228
|
not b
|
229
|
| None ->
|
230
|
not nd.node_dec_stateless)
|
231
|
| ImportedNode nd ->
|
232
|
not nd.nodei_stateless
|
233
|
| _ ->
|
234
|
false
|
235
|
|
236
|
let rec load_rec ~is_header accu program =
|
237
|
List.fold_left
|
238
|
(fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
|
239
|
(* Precompute the updated envs, will not be used in the Open case *)
|
240
|
let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
|
241
|
match decl.top_decl_desc with
|
242
|
| Open (local, dep) -> (
|
243
|
(* loading the dep *)
|
244
|
try
|
245
|
let basename =
|
246
|
name_dependency decl.top_decl_loc (local, dep) ".lusic"
|
247
|
in
|
248
|
if
|
249
|
List.exists
|
250
|
(fun dep ->
|
251
|
basename
|
252
|
= name_dependency decl.top_decl_loc (dep.local, dep.name)
|
253
|
".lusic")
|
254
|
accu_dep
|
255
|
then (* Library already imported. Just skip *)
|
256
|
accu
|
257
|
else (
|
258
|
Log.report ~level:1 (fun fmt ->
|
259
|
Format.fprintf fmt "@ .. Library %s@ " basename);
|
260
|
let lusic = get_lusic decl in
|
261
|
(* Recursive call with accumulator on lusic *)
|
262
|
let accu_prog, accu_dep, typ_env, clk_env =
|
263
|
load_rec ~is_header:true accu lusic.Lusic.contents
|
264
|
in
|
265
|
(* Building the dep *)
|
266
|
let is_stateful = List.exists is_stateful lusic.Lusic.contents in
|
267
|
let new_dep =
|
268
|
{ local; name = dep; content = lusic.Lusic.contents; is_stateful }
|
269
|
in
|
270
|
|
271
|
(* Returning the prog while keeping the Open, the deps with the new
|
272
|
elements and the updated envs *)
|
273
|
decl :: accu_prog, new_dep :: accu_dep, typ_env, clk_env)
|
274
|
with Not_found ->
|
275
|
let loc = decl.top_decl_loc in
|
276
|
Error.pp_error loc (fun fmt ->
|
277
|
Format.fprintf fmt "Unknown library %s" dep);
|
278
|
raise (Error.Error (loc, Error.Unknown_library dep (*basename*))))
|
279
|
| Include name ->
|
280
|
let basename = name_dependency decl.top_decl_loc (true, name) "" in
|
281
|
if Filename.check_suffix basename ".lus" then
|
282
|
let include_src = Compiler_common.parse basename ".lus" in
|
283
|
let accu_prog, accu_dep, typ_env, clk_env =
|
284
|
load_rec ~is_header:false accu include_src
|
285
|
in
|
286
|
decl :: accu_prog, accu_dep, typ_env, clk_env
|
287
|
else
|
288
|
raise
|
289
|
(Error.Error
|
290
|
(decl.top_decl_loc, LoadError "include requires a lustre file"))
|
291
|
| Node nd ->
|
292
|
if is_header then
|
293
|
raise
|
294
|
(Error.Error
|
295
|
( decl.top_decl_loc,
|
296
|
LoadError ("node " ^ nd.node_id ^ " declared in a header file")
|
297
|
))
|
298
|
else (
|
299
|
(* Registering node *)
|
300
|
add_node nd.node_id decl;
|
301
|
(* Updating the type/clock env *)
|
302
|
decl :: accu_prog, accu_dep, typ_env', clk_env')
|
303
|
| ImportedNode ind ->
|
304
|
if is_header then (
|
305
|
add_imported_node ind.nodei_id decl;
|
306
|
decl :: accu_prog, accu_dep, typ_env', clk_env')
|
307
|
else
|
308
|
raise
|
309
|
(Error.Error
|
310
|
( decl.top_decl_loc,
|
311
|
LoadError
|
312
|
("imported node " ^ ind.nodei_id
|
313
|
^ " declared in a regular Lustre file") ))
|
314
|
| Const c ->
|
315
|
add_const c.const_id decl;
|
316
|
decl :: accu_prog, accu_dep, typ_env', clk_env'
|
317
|
| TypeDef tdef ->
|
318
|
add_type is_header tdef.tydef_id decl;
|
319
|
decl :: accu_prog, accu_dep, typ_env', clk_env')
|
320
|
accu program
|
321
|
|
322
|
(* Iterates through lusi definitions and records them in the hashtbl. Open
|
323
|
instructions are evaluated and update these hashtbl as well.
|
324
|
node_table/type/table/consts_table *)
|
325
|
let load ~is_header program =
|
326
|
try
|
327
|
let prog, deps, typ_env, clk_env =
|
328
|
load_rec ~is_header
|
329
|
( [],
|
330
|
(* accumulator for program elements *)
|
331
|
[],
|
332
|
(* accumulator for dependencies *)
|
333
|
Env.initial,
|
334
|
(* empty type env *)
|
335
|
Env.initial (* empty clock env *) )
|
336
|
program
|
337
|
in
|
338
|
List.rev prog, List.rev deps, (typ_env, clk_env)
|
339
|
with Error.Error (_, err) as exc ->
|
340
|
(* Format.eprintf "Import error: %a%a@."
|
341
|
* Error.pp_error_msg err
|
342
|
* Location.pp_loc loc; *)
|
343
|
Format.eprintf "Import error: %a@." Error.pp_error_msg err;
|
344
|
raise exc
|