Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / types.ml @ 45c13277

History | View | Annotate | Download (9.52 KB)

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