lustrec / src / modules.ml @ 86ae18b7
History | View | Annotate | Download (7.91 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 LustreSpec |
14 |
open Corelang |
15 |
|
16 |
let add_symbol loc msg hashtbl name value = |
17 |
if Hashtbl.mem hashtbl name |
18 |
then raise (Error (loc, 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, Unbound_symbol msg)) |
24 |
else () |
25 |
|
26 |
let add_imported_node name value = |
27 |
(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*) |
28 |
try |
29 |
let value' = Hashtbl.find node_table name in |
30 |
let owner' = value'.top_decl_owner in |
31 |
let itf' = value'.top_decl_itf in |
32 |
let owner = value.top_decl_owner in |
33 |
let itf = value.top_decl_itf in |
34 |
match value'.top_decl_desc, value.top_decl_desc with |
35 |
| Node _ , ImportedNode _ when owner = owner' && itf' && (not itf) -> Hashtbl.add node_table name value |
36 |
| ImportedNode _, ImportedNode _ -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name))) |
37 |
| _ -> assert false |
38 |
with |
39 |
Not_found -> Hashtbl.add node_table name value |
40 |
|
41 |
let add_node name value = |
42 |
(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node (get_node_interface (node_of_top value)) value.top_decl_owner;*) |
43 |
try |
44 |
let value' = Hashtbl.find node_table name in |
45 |
let owner' = value'.top_decl_owner in |
46 |
let itf' = value'.top_decl_itf in |
47 |
let owner = value.top_decl_owner in |
48 |
let itf = value.top_decl_itf in |
49 |
match value'.top_decl_desc, value.top_decl_desc with |
50 |
| ImportedNode _, Node _ when owner = owner' && itf' && (not itf) -> () |
51 |
| Node _ , Node _ -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name))) |
52 |
| _ -> assert false |
53 |
with |
54 |
Not_found -> Hashtbl.add node_table name value |
55 |
|
56 |
|
57 |
let add_tag loc name typ = |
58 |
if Hashtbl.mem tag_table name then |
59 |
raise (Error (loc, Already_bound_symbol ("enum tag " ^ name))) |
60 |
else Hashtbl.add tag_table name typ |
61 |
|
62 |
let add_field loc name typ = |
63 |
if Hashtbl.mem field_table name then |
64 |
raise (Error (loc, Already_bound_symbol ("struct field " ^ name))) |
65 |
else Hashtbl.add field_table name typ |
66 |
|
67 |
let import_typedef name tydef = |
68 |
let loc = tydef.top_decl_loc in |
69 |
let rec import ty = |
70 |
match ty with |
71 |
| Tydec_enum tl -> |
72 |
List.iter (fun tag -> add_tag loc tag tydef) tl |
73 |
| Tydec_struct fl -> |
74 |
List.iter (fun (field, ty) -> add_field loc field tydef; import ty) fl |
75 |
| Tydec_clock ty -> import ty |
76 |
| Tydec_const c -> |
77 |
if not (Hashtbl.mem type_table (Tydec_const c)) |
78 |
then raise (Error (loc, Unbound_symbol ("type " ^ c))) |
79 |
else () |
80 |
| Tydec_array (c, ty) -> import ty |
81 |
| _ -> () |
82 |
in import ((typedef_of_top tydef).tydef_desc) |
83 |
|
84 |
let add_type itf name value = |
85 |
(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*) |
86 |
try |
87 |
let value' = Hashtbl.find type_table (Tydec_const name) in |
88 |
let owner' = value'.top_decl_owner in |
89 |
let itf' = value'.top_decl_itf in |
90 |
let owner = value.top_decl_owner in |
91 |
let itf = value.top_decl_itf in |
92 |
match value'.top_decl_desc, value.top_decl_desc with |
93 |
| TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> () |
94 |
| TypeDef ty', TypeDef ty -> raise (Error (value.top_decl_loc, Already_bound_symbol ("type " ^ name))) |
95 |
| _ -> assert false |
96 |
with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value) |
97 |
|
98 |
let check_type loc name = |
99 |
if not (Hashtbl.mem type_table (Tydec_const name)) |
100 |
then raise (Error (loc, Unbound_symbol ("type " ^ name))) |
101 |
else () |
102 |
|
103 |
let add_const itf name value = |
104 |
try |
105 |
let value' = Hashtbl.find consts_table name in |
106 |
let owner' = value'.top_decl_owner in |
107 |
let itf' = value'.top_decl_itf in |
108 |
let owner = value.top_decl_owner in |
109 |
let itf = value.top_decl_itf in |
110 |
match value'.top_decl_desc, value.top_decl_desc with |
111 |
| Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> () |
112 |
| Const c', Const c -> raise (Error (value.top_decl_loc, Already_bound_symbol ("const " ^ name))) |
113 |
| _ -> assert false |
114 |
with Not_found -> Hashtbl.add consts_table name value |
115 |
|
116 |
(*let name_dependency (local, dep) = |
117 |
((if local then !Options.dest_dir else Version.include_path) ^ "/") ^ dep |
118 |
*) |
119 |
|
120 |
let name_dependency (local, dep) = |
121 |
((if local then !Options.dest_dir else !Options.include_dir) ^ "/") ^ dep |
122 |
|
123 |
let import_dependency_aux loc (local, dep) = |
124 |
let basename = name_dependency (local, dep) in |
125 |
let extension = ".lusic" in |
126 |
try |
127 |
let lusic = Lusic.read_lusic basename extension in |
128 |
Lusic.check_obsolete lusic basename; |
129 |
lusic |
130 |
with |
131 |
| Sys_error msg -> |
132 |
begin |
133 |
(*Format.eprintf "Error: %s@." msg;*) |
134 |
raise (Error (loc, Unknown_library basename)) |
135 |
end |
136 |
| Corelang.Error (_, msg) -> raise (Corelang.Error (loc, msg)) |
137 |
|
138 |
let import_dependency loc (local, dep) = |
139 |
try |
140 |
import_dependency_aux loc (local, dep) |
141 |
with |
142 |
| Corelang.Error (_, err) as exc -> ( |
143 |
Format.eprintf "Import error: %a%a@." |
144 |
Corelang.pp_error err |
145 |
Location.pp_loc loc; |
146 |
raise exc |
147 |
) |
148 |
|
149 |
let check_dependency lusic basename = |
150 |
try |
151 |
Lusic.check_obsolete lusic basename |
152 |
with |
153 |
| Corelang.Error (loc, err) as exc -> ( |
154 |
Format.eprintf "Import error: %a%a@." |
155 |
Corelang.pp_error err |
156 |
Location.pp_loc loc; |
157 |
raise exc |
158 |
) |
159 |
|
160 |
let rec load_header_rec imported header = |
161 |
List.fold_left (fun imp decl -> |
162 |
match decl.top_decl_desc with |
163 |
| Node nd -> assert false |
164 |
| ImportedNode ind -> (add_imported_node ind.nodei_id decl; imp) |
165 |
| Const c -> (add_const true c.const_id decl; imp) |
166 |
| TypeDef tdef -> (add_type true tdef.tydef_id decl; imp) |
167 |
| Open (local, dep) -> |
168 |
let basename = name_dependency (local, dep) in |
169 |
if ISet.mem basename imported then imp else |
170 |
let lusic = import_dependency_aux decl.top_decl_loc (local, dep) |
171 |
in load_header_rec (ISet.add basename imported) lusic.Lusic.contents |
172 |
) imported header |
173 |
|
174 |
let load_header imported header = |
175 |
try |
176 |
load_header_rec imported header |
177 |
with |
178 |
Corelang.Error (loc, err) as exc -> ( |
179 |
Format.eprintf "Import error: %a%a@." |
180 |
Corelang.pp_error err |
181 |
Location.pp_loc loc; |
182 |
raise exc |
183 |
);; |
184 |
|
185 |
let rec load_program_rec imported program = |
186 |
List.fold_left (fun imp decl -> |
187 |
match decl.top_decl_desc with |
188 |
| Node nd -> (add_node nd.node_id decl; imp) |
189 |
| ImportedNode ind -> assert false |
190 |
| Const c -> (add_const false c.const_id decl; imp) |
191 |
| TypeDef tdef -> (add_type false tdef.tydef_id decl; imp) |
192 |
| Open (local, dep) -> |
193 |
let basename = name_dependency (local, dep) in |
194 |
if ISet.mem basename imported then imp else |
195 |
let lusic = import_dependency_aux decl.top_decl_loc (local, dep) |
196 |
in load_header_rec (ISet.add basename imported) lusic.Lusic.contents |
197 |
) imported program |
198 |
|
199 |
let load_program imported program = |
200 |
try |
201 |
load_program_rec imported program |
202 |
with |
203 |
Corelang.Error (loc, err) as exc -> ( |
204 |
Format.eprintf "Import error: %a%a@." |
205 |
Corelang.pp_error err |
206 |
Location.pp_loc loc; |
207 |
raise exc |
208 |
);; |