Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / types.ml @ 12af4908

History | View | Annotate | Download (8.64 KB)

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