lustrec / src / types.ml @ e24b2e9b
History | View | Annotate | Download (9.88 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT - LIFL *) |
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 |
(* This file was originally from the Prelude compiler *) |
11 |
(* *) |
12 |
(********************************************************************) |
13 |
|
14 |
(** Types definitions and a few utility functions on types. *) |
15 |
open Utils |
16 |
open Dimension |
17 |
|
18 |
type type_expr = |
19 |
{mutable tdesc: type_desc; |
20 |
tid: int} |
21 |
|
22 |
and type_desc = |
23 |
| Tconst of ident (* type constant *) |
24 |
| Tint |
25 |
| Treal |
26 |
| Tbool |
27 |
| Trat (* Actually unused for now. Only place where it can appear is |
28 |
in a clock declaration *) |
29 |
| Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *) |
30 |
| Tarrow of type_expr * type_expr |
31 |
| Ttuple of type_expr list |
32 |
| Tenum of ident list |
33 |
| Tstruct of (ident * type_expr) list |
34 |
| Tarray of dim_expr * type_expr |
35 |
| Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *) |
36 |
| Tlink of type_expr (* During unification, make links instead of substitutions *) |
37 |
| Tvar (* Monomorphic type variable *) |
38 |
| Tunivar (* Polymorphic type variable *) |
39 |
|
40 |
type error = |
41 |
Unbound_value of ident |
42 |
| Already_bound of ident |
43 |
| Already_defined of ident |
44 |
| Undefined_var of ISet.t |
45 |
| Declared_but_undefined of ident |
46 |
| Unbound_type of ident |
47 |
| Not_a_dimension |
48 |
| Not_a_constant |
49 |
| Assigned_constant of ident |
50 |
| WrongArity of int * int |
51 |
| WrongMorphism of int * int |
52 |
| Type_mismatch of ident |
53 |
| Type_clash of type_expr * type_expr |
54 |
| Poly_imported_node of ident |
55 |
|
56 |
exception Unify of type_expr * type_expr |
57 |
exception Error of Location.t * error |
58 |
|
59 |
(* Pretty-print*) |
60 |
open Format |
61 |
|
62 |
let rec print_struct_ty_field fmt (label, ty) = |
63 |
fprintf fmt "%a : %a" pp_print_string label print_ty ty |
64 |
and print_ty fmt ty = |
65 |
match ty.tdesc with |
66 |
| Tvar -> |
67 |
fprintf fmt "_%s" (name_of_type ty.tid) |
68 |
| Tint -> |
69 |
fprintf fmt "int" |
70 |
| Treal -> |
71 |
fprintf fmt "real" |
72 |
| Tbool -> |
73 |
fprintf fmt "bool" |
74 |
| Tclock t -> |
75 |
fprintf fmt "%a clock" print_ty t |
76 |
| Tstatic (d, t) -> |
77 |
fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t |
78 |
| Tconst t -> |
79 |
fprintf fmt "%s" t |
80 |
| Trat -> |
81 |
fprintf fmt "rat" |
82 |
| Tarrow (ty1,ty2) -> |
83 |
fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2 |
84 |
| Ttuple tylist -> |
85 |
fprintf fmt "(%a)" |
86 |
(Utils.fprintf_list ~sep:" * " print_ty) tylist |
87 |
| Tenum taglist -> |
88 |
fprintf fmt "enum {%a }" |
89 |
(Utils.fprintf_list ~sep:", " pp_print_string) taglist |
90 |
| Tstruct fieldlist -> |
91 |
fprintf fmt "struct {%a }" |
92 |
(Utils.fprintf_list ~sep:"; " print_struct_ty_field) fieldlist |
93 |
| Tarray (e, ty) -> |
94 |
fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e |
95 |
| Tlink ty -> |
96 |
print_ty fmt ty |
97 |
| Tunivar -> |
98 |
fprintf fmt "'%s" (name_of_type ty.tid) |
99 |
|
100 |
let rec print_node_struct_ty_field fmt (label, ty) = |
101 |
fprintf fmt "%a : %a" pp_print_string label print_node_ty ty |
102 |
and print_node_ty fmt ty = |
103 |
match ty.tdesc with |
104 |
| Tvar -> begin |
105 |
(*Format.eprintf "DEBUG:Types.print_node@.";*) |
106 |
fprintf fmt "_%s" (name_of_type ty.tid) |
107 |
end |
108 |
| Tint -> |
109 |
fprintf fmt "int" |
110 |
| Treal -> |
111 |
fprintf fmt "real" |
112 |
| Tbool -> |
113 |
fprintf fmt "bool" |
114 |
| Tclock t -> |
115 |
fprintf fmt "%a clock" print_node_ty t |
116 |
| Tstatic (_, t) -> |
117 |
fprintf fmt "%a" print_node_ty t |
118 |
| Tconst t -> |
119 |
fprintf fmt "%s" t |
120 |
| Trat -> |
121 |
fprintf fmt "rat" |
122 |
| Tarrow (ty1,ty2) -> |
123 |
fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2 |
124 |
| Ttuple tylist -> |
125 |
fprintf fmt "(%a)" |
126 |
(Utils.fprintf_list ~sep:"*" print_node_ty) tylist |
127 |
| Tenum taglist -> |
128 |
fprintf fmt "enum {%a }" |
129 |
(Utils.fprintf_list ~sep:", " pp_print_string) taglist |
130 |
| Tstruct fieldlist -> |
131 |
fprintf fmt "struct {%a }" |
132 |
(Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist |
133 |
| Tarray (e, ty) -> |
134 |
fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e |
135 |
| Tlink ty -> |
136 |
print_node_ty fmt ty |
137 |
| Tunivar -> |
138 |
fprintf fmt "'%s" (name_of_type ty.tid) |
139 |
|
140 |
let pp_error fmt = function |
141 |
| Unbound_value id -> |
142 |
fprintf fmt "Unknown value %s@." id |
143 |
| Unbound_type id -> |
144 |
fprintf fmt "Unknown type %s@." id |
145 |
| Already_bound id -> |
146 |
fprintf fmt "%s is already declared@." id |
147 |
| Already_defined id -> |
148 |
fprintf fmt "Multiple definitions of variable %s@." id |
149 |
| Not_a_constant -> |
150 |
fprintf fmt "This expression is not a constant@." |
151 |
| Assigned_constant id -> |
152 |
fprintf fmt "The constant %s cannot be assigned@." id |
153 |
| Not_a_dimension -> |
154 |
fprintf fmt "This expression is not a valid dimension@." |
155 |
| WrongArity (ar1, ar2) -> |
156 |
fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2 |
157 |
| WrongMorphism (ar1, ar2) -> |
158 |
fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2 |
159 |
| Type_mismatch id -> |
160 |
fprintf fmt "Definition and declaration of type %s don't agree@." id |
161 |
| Undefined_var vset -> |
162 |
fprintf fmt "No definition provided for variable(s): %a@." |
163 |
(Utils.fprintf_list ~sep:"," pp_print_string) |
164 |
(ISet.elements vset) |
165 |
| Declared_but_undefined id -> |
166 |
fprintf fmt "%s is declared but not defined@." id |
167 |
| Type_clash (ty1,ty2) -> |
168 |
Utils.reset_names (); |
169 |
fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2 |
170 |
| Poly_imported_node id -> |
171 |
fprintf fmt "Imported nodes cannot have a polymorphic type@." |
172 |
|
173 |
|
174 |
let new_id = ref (-1) |
175 |
|
176 |
let new_ty desc = |
177 |
incr new_id; {tdesc = desc; tid = !new_id } |
178 |
|
179 |
let new_var () = |
180 |
new_ty Tvar |
181 |
|
182 |
let new_univar () = |
183 |
new_ty Tunivar |
184 |
|
185 |
let rec repr = |
186 |
function |
187 |
{tdesc = Tlink t'} -> |
188 |
repr t' |
189 |
| t -> t |
190 |
|
191 |
let get_static_value ty = |
192 |
match (repr ty).tdesc with |
193 |
| Tstatic (d, _) -> Some d |
194 |
| _ -> None |
195 |
|
196 |
let get_field_type ty label = |
197 |
match (repr ty).tdesc with |
198 |
| Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None) |
199 |
| _ -> None |
200 |
|
201 |
let is_numeric_type ty = |
202 |
match (repr ty).tdesc with |
203 |
| Tint |
204 |
| Treal -> true |
205 |
| _ -> false |
206 |
|
207 |
let is_bool_type ty = |
208 |
match (repr ty).tdesc with |
209 |
| Tbool -> true |
210 |
| _ -> false |
211 |
|
212 |
let get_clock_base_type ty = |
213 |
match (repr ty).tdesc with |
214 |
| Tclock ty -> Some ty |
215 |
| _ -> None |
216 |
|
217 |
let unclock_type ty = |
218 |
let ty = repr ty in |
219 |
match ty.tdesc with |
220 |
| Tclock ty' -> ty' |
221 |
| _ -> ty |
222 |
|
223 |
let rec is_dimension_type ty = |
224 |
match (repr ty).tdesc with |
225 |
| Tint |
226 |
| Tbool -> true |
227 |
| Tclock ty' |
228 |
| Tstatic (_, ty') -> is_dimension_type ty' |
229 |
| _ -> false |
230 |
|
231 |
let dynamic_type ty = |
232 |
let ty = repr ty in |
233 |
match ty.tdesc with |
234 |
| Tstatic (_, ty') -> ty' |
235 |
| _ -> ty |
236 |
|
237 |
let is_tuple_type ty = |
238 |
match (repr ty).tdesc with |
239 |
| Ttuple _ -> true |
240 |
| _ -> false |
241 |
|
242 |
let map_tuple_type f ty = |
243 |
let ty = dynamic_type ty in |
244 |
match ty.tdesc with |
245 |
| (Ttuple ty_list) -> { ty with tdesc = Ttuple (List.map f ty_list) } |
246 |
| _ -> f ty |
247 |
|
248 |
let rec is_struct_type ty = |
249 |
match (repr ty).tdesc with |
250 |
| Tstruct _ -> true |
251 |
| Tstatic (_, ty') -> is_struct_type ty' |
252 |
| _ -> false |
253 |
|
254 |
let rec is_array_type ty = |
255 |
match (repr ty).tdesc with |
256 |
| Tarray _ -> true |
257 |
| Tstatic (_, ty') -> is_array_type ty' (* looks strange !? *) |
258 |
| _ -> false |
259 |
|
260 |
let array_type_dimension ty = |
261 |
match (dynamic_type ty).tdesc with |
262 |
| Tarray (d, _) -> d |
263 |
| _ -> (Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty ty; assert false) |
264 |
|
265 |
let rec array_type_multi_dimension ty = |
266 |
match (dynamic_type ty).tdesc with |
267 |
| Tarray (d, ty') -> d :: array_type_multi_dimension ty' |
268 |
| _ -> [] |
269 |
|
270 |
let array_element_type ty = |
271 |
match (dynamic_type ty).tdesc with |
272 |
| Tarray (_, ty') -> ty' |
273 |
| _ -> (Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty; assert false) |
274 |
|
275 |
let rec array_base_type ty = |
276 |
let ty = repr ty in |
277 |
match ty.tdesc with |
278 |
| Tarray (_, ty') |
279 |
| Tstatic (_, ty') -> array_base_type ty' |
280 |
| _ -> ty |
281 |
|
282 |
let is_address_type ty = |
283 |
is_array_type ty || is_struct_type ty |
284 |
|
285 |
let rec is_generic_type ty = |
286 |
match (dynamic_type ty).tdesc with |
287 |
| Tarray (d, ty') -> |
288 |
(not (Dimension.is_dimension_const d)) || (is_generic_type ty') |
289 |
| _ -> false |
290 |
|
291 |
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type |
292 |
(ensured by language syntax) *) |
293 |
let rec split_arrow ty = |
294 |
match (repr ty).tdesc with |
295 |
| Tarrow (tin,tout) -> tin,tout |
296 |
| Tstatic (_, ty') -> split_arrow ty' |
297 |
(* Functions are not first order, I don't think the var case |
298 |
needs to be considered here *) |
299 |
| _ -> Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty; assert false |
300 |
|
301 |
(** Returns the type corresponding to a type list. *) |
302 |
let type_of_type_list tyl = |
303 |
if (List.length tyl) > 1 then |
304 |
new_ty (Ttuple tyl) |
305 |
else |
306 |
List.hd tyl |
307 |
|
308 |
let type_list_of_type ty = |
309 |
match (repr ty).tdesc with |
310 |
| Ttuple tl -> tl |
311 |
| _ -> [ty] |
312 |
|
313 |
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *) |
314 |
let rec is_polymorphic ty = |
315 |
match ty.tdesc with |
316 |
| Tenum _ | Tvar | Tint | Treal | Tbool | Trat | Tconst _ -> false |
317 |
| Tclock ty -> is_polymorphic ty |
318 |
| Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2) |
319 |
| Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl |
320 |
| Tstruct fl -> List.exists (fun (_, t) -> is_polymorphic t) fl |
321 |
| Tlink t' -> is_polymorphic t' |
322 |
| Tarray (d, ty) |
323 |
| Tstatic (d, ty) -> Dimension.is_polymorphic d || is_polymorphic ty |
324 |
| Tunivar -> true |
325 |
|
326 |
|
327 |
let mktyptuple nb typ = |
328 |
let array = Array.make nb typ in |
329 |
Ttuple (Array.to_list array) |
330 |
|
331 |
|
332 |
(* Local Variables: *) |
333 |
(* compile-command:"make -C .." *) |
334 |
(* End: *) |