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