Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / types.ml @ 59294251

History | View | Annotate | Download (9.81 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2011, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 *
5
 * This file is part of Prelude
6
 *
7
 * Prelude is free software; you can redistribute it and/or
8
 * modify it under the terms of the GNU Lesser General Public License
9
 * as published by the Free Software Foundation ; either version 2 of
10
 * the License, or (at your option) any later version.
11
 *
12
 * Prelude is distributed in the hope that it will be useful, but
13
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
14
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
 * Lesser General Public License for more details.
16
 *
17
 * You should have received a copy of the GNU Lesser General Public
18
 * License along with this program ; if not, write to the Free Software
19
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
20
 * USA
21
 *---------------------------------------------------------------------------- *)
22

    
23
(** Types definitions and a few utility functions on types. *)
24
open Utils
25
open Dimension
26

    
27
type type_expr =
28
    {mutable tdesc: type_desc;
29
     tid: int}
30

    
31
and type_desc =
32
  | Tconst of ident (* type constant *)
33
  | Tint
34
  | Treal
35
  | Tbool
36
  | Trat (* Actually unused for now. Only place where it can appear is
37
            in a clock declaration *)
38
  | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
39
  | Tarrow of type_expr * type_expr
40
  | Ttuple of type_expr list
41
  | Tenum of ident list
42
  | Tstruct of (ident * type_expr) list
43
  | Tarray of dim_expr * type_expr
44
  | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
45
  | Tlink of type_expr (* During unification, make links instead of substitutions *)
46
  | Tvar (* Monomorphic type variable *)
47
  | Tunivar (* Polymorphic type variable *)
48

    
49
type error =
50
    Unbound_value of ident  
51
  | Already_bound of ident
52
  | Already_defined of ident
53
  | Undefined_var of (unit IMap.t)
54
  | Declared_but_undefined of ident
55
  | Unbound_type of ident
56
  | Not_a_dimension
57
  | Not_a_constant
58
  | Assigned_constant of ident
59
  | WrongArity of int * int
60
  | WrongMorphism of int * int
61
  | Type_clash of type_expr * type_expr
62
  | Poly_imported_node of ident
63

    
64
exception Unify of type_expr * type_expr
65
exception Error of Location.t * error
66

    
67
(* Pretty-print*)
68
open Format
69

    
70
let rec print_struct_ty_field fmt (label, ty) =
71
  fprintf fmt "%a : %a" pp_print_string label print_ty ty
72
and print_ty fmt ty =
73
  match ty.tdesc with
74
  | Tvar ->
75
    fprintf fmt "_%s" (name_of_type ty.tid)
76
  | Tint ->
77
    fprintf fmt "int"
78
  | Treal ->
79
    fprintf fmt "real"
80
  | Tbool ->
81
    fprintf fmt "bool"
82
  | Tclock t ->
83
    fprintf fmt "%a clock" print_ty t
84
  | Tstatic (d, t) ->
85
    fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t
86
  | Tconst t ->
87
    fprintf fmt "%s" t
88
  | Trat ->
89
    fprintf fmt "rat"
90
  | Tarrow (ty1,ty2) ->
91
    fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
92
  | Ttuple tylist ->
93
    fprintf fmt "(%a)"
94
      (Utils.fprintf_list ~sep:"*" print_ty) tylist
95
  | Tenum taglist ->
96
    fprintf fmt "enum {%a }"
97
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
98
  | Tstruct fieldlist ->
99
    fprintf fmt "struct {%a }"
100
      (Utils.fprintf_list ~sep:"; " print_struct_ty_field) fieldlist
101
  | Tarray (e, ty) ->
102
    fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
103
  | Tlink ty ->
104
      print_ty fmt ty
105
  | Tunivar ->
106
    fprintf fmt "'%s" (name_of_type ty.tid)
107

    
108
let rec print_node_struct_ty_field fmt (label, ty) =
109
  fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
110
and print_node_ty fmt ty =
111
  match ty.tdesc with
112
  | Tvar -> begin
113
(*Format.eprintf "DEBUG:Types.print_node@.";*)
114
    fprintf fmt "_%s" (name_of_type ty.tid)
115
end
116
  | Tint ->
117
    fprintf fmt "int"
118
  | Treal ->
119
    fprintf fmt "real"
120
  | Tbool ->
121
    fprintf fmt "bool"
122
  | Tclock t ->
123
    fprintf fmt "%a clock" print_node_ty t
124
  | Tstatic (_, t) ->
125
    fprintf fmt "%a" print_node_ty t
126
  | Tconst t ->
127
    fprintf fmt "%s" t
128
  | Trat ->
129
    fprintf fmt "rat"
130
  | Tarrow (ty1,ty2) ->
131
    fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
132
  | Ttuple tylist ->
133
    fprintf fmt "(%a)"
134
      (Utils.fprintf_list ~sep:"*" print_node_ty) tylist
135
  | Tenum taglist ->
136
    fprintf fmt "enum {%a }"
137
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
138
  | Tstruct fieldlist ->
139
    fprintf fmt "struct {%a }"
140
      (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist
141
  | Tarray (e, ty) ->
142
    fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e
143
  | Tlink ty ->
144
      print_node_ty fmt ty
145
  | Tunivar ->
146
    fprintf fmt "'%s" (name_of_type ty.tid)
147

    
148
let pp_error fmt = function
149
  | Unbound_value id ->
150
    fprintf fmt "Unknown value %s@." id
151
  | Unbound_type id ->
152
    fprintf fmt "Unknown type %s@." id
153
  | Already_bound id ->
154
    fprintf fmt "%s is already declared@." id
155
  | Already_defined id ->
156
    fprintf fmt "Multiple definitions of variable %s@." id
157
  | Not_a_constant ->
158
    fprintf fmt "This expression is not a constant@."
159
  | Assigned_constant id ->
160
    fprintf fmt "The constant %s cannot be assigned@." id
161
  | Not_a_dimension ->
162
    fprintf fmt "This expression is not a valid dimension@."
163
  | WrongArity (ar1, ar2) ->
164
    fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
165
  | WrongMorphism (ar1, ar2) ->
166
    fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
167
  | Undefined_var vmap ->
168
    fprintf fmt "No definition provided for variable(s): %a@."
169
      (Utils.fprintf_list ~sep:"," pp_print_string)
170
      (fst (Utils.list_of_imap vmap))
171
  | Declared_but_undefined id ->
172
     fprintf fmt "Node %s is declared but not defined@." id
173
  | Type_clash (ty1,ty2) ->
174
      Utils.reset_names ();
175
    fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
176
  | Poly_imported_node id ->
177
    fprintf fmt "Imported nodes cannot have a polymorphic type@."
178

    
179

    
180
let new_id = ref (-1)
181

    
182
let new_ty desc =
183
  incr new_id; {tdesc = desc; tid = !new_id }
184

    
185
let new_var () =
186
  new_ty Tvar
187

    
188
let new_univar () =
189
  new_ty Tunivar
190

    
191
let rec repr =
192
  function
193
    {tdesc = Tlink t'} ->
194
      repr t'
195
  | t -> t
196

    
197
let get_static_value ty =
198
  match (repr ty).tdesc with
199
  | Tstatic (d, _) -> Some d
200
  | _              -> None
201

    
202
let get_field_type ty label =
203
  match (repr ty).tdesc with
204
  | Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
205
  | _          -> None
206

    
207
let is_numeric_type ty =
208
 match (repr ty).tdesc with
209
 | Tint
210
 | Treal -> true
211
 | _     -> false
212

    
213
let is_bool_type ty =
214
 match (repr ty).tdesc with
215
 | Tbool -> true
216
 | _     -> false
217

    
218
let get_clock_base_type ty =
219
 match (repr ty).tdesc with
220
 | Tclock ty -> Some ty
221
 | _         -> None
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 rec is_nested_tuple_type ty =
243
 match (repr ty).tdesc with
244
 | Ttuple tl        -> List.exists is_tuple_type tl
245
 | _                -> false
246

    
247
let map_tuple_type f ty =
248
  let ty = dynamic_type ty in
249
  match ty.tdesc with
250
  | (Ttuple ty_list) -> { ty with tdesc = Ttuple (List.map f ty_list) }
251
  | _                -> f ty
252

    
253
let is_struct_type ty =
254
 match (repr ty).tdesc with
255
 | Tstruct _        -> true
256
 | _                -> false
257

    
258
let rec is_array_type ty =
259
 match (repr ty).tdesc with
260
 | Tarray _         -> true
261
 | Tstatic (_, ty') -> is_array_type ty' (* looks strange !? *)
262
 | _                -> false
263

    
264
let array_type_dimension ty =
265
  match (dynamic_type ty).tdesc with
266
  | Tarray (d, _) -> d
267
  | _             -> assert false
268

    
269
let rec array_type_multi_dimension ty =
270
  match (dynamic_type ty).tdesc with
271
  | Tarray (d, ty') -> d :: array_type_multi_dimension ty'
272
  | _               -> []
273

    
274
let array_element_type ty =
275
  match (dynamic_type ty).tdesc with
276
  | Tarray (_, ty') -> ty'
277
  | _               -> assert false
278

    
279
let rec array_base_type ty =
280
  let ty = repr ty in
281
  match ty.tdesc with
282
  | Tarray (_, ty')
283
  | Tstatic (_, ty') -> array_base_type ty'
284
  | _                -> ty
285

    
286
let is_address_type ty =
287
  is_array_type ty || is_struct_type ty
288

    
289
let rec is_generic_type ty =
290
 match (dynamic_type ty).tdesc with
291
  | Tarray (d, ty') ->
292
    (not (Dimension.is_dimension_const d)) || (is_generic_type ty')
293
  | _               -> false
294

    
295
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
296
    (ensured by language syntax) *)
297
let rec split_arrow ty =
298
  match (repr ty).tdesc with
299
  | Tarrow (tin,tout) -> tin,tout
300
  | Tstatic (_, ty')  -> split_arrow ty'
301
    (* Functions are not first order, I don't think the var case
302
       needs to be considered here *)
303
  | _ -> Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty; assert false
304

    
305
(** Returns the type corresponding to a type list. *)
306
let type_of_type_list tyl =
307
  if (List.length tyl) > 1 then
308
    new_ty (Ttuple tyl)
309
  else
310
    List.hd tyl
311

    
312
let type_list_of_type ty =
313
 match (repr ty).tdesc with
314
 | Ttuple tl -> tl
315
 | _         -> [ty]
316

    
317
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
318
let rec is_polymorphic ty =
319
  match ty.tdesc with
320
  | Tenum _ | Tvar | Tint | Treal | Tbool | Trat | Tconst _ -> false
321
  | Tclock ty -> is_polymorphic ty
322
  | Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2)
323
  | Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl
324
  | Tstruct fl -> List.exists (fun (_, t) -> is_polymorphic t) fl
325
  | Tlink t' -> is_polymorphic t'
326
  | Tarray (d, ty)
327
  | Tstatic (d, ty) -> Dimension.is_polymorphic d || is_polymorphic ty
328
  | Tunivar -> true
329

    
330

    
331
let mktyptuple nb typ =
332
  let array = Array.make nb typ in
333
  Ttuple (Array.to_list array)
334

    
335

    
336
(* Local Variables: *)
337
(* compile-command:"make -C .." *)
338
(* End: *)