Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/types.ml
6 6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7 7
(*  under the terms of the GNU Lesser General Public License        *)
8 8
(*  version 2.1.                                                    *)
9
(*                                                                  *) 
9
(*                                                                  *)
10 10
(*  This file was originally from the Prelude compiler              *)
11
(*                                                                  *) 
11
(*                                                                  *)
12 12
(********************************************************************)
13 13

  
14
(** Types definitions and a few utility functions on types. *)
15 14
open Utils
15
(** Types definitions and a few utility functions on types. *)
16

  
16 17
open Dimension
17 18

  
18
module type BASIC_TYPES =
19
sig
19
module type BASIC_TYPES = sig
20 20
  type t
21
  val pp: Format.formatter -> t -> unit
22
  val pp_c: Format.formatter -> t -> unit
23
  val is_scalar_type: t -> bool
24
  val is_numeric_type: t -> bool
25
  val is_int_type: t -> bool
26
  val is_real_type: t -> bool
27
  val is_bool_type: t -> bool
28
  val is_dimension_type: t -> bool
29
  val type_int_builder: t
30
  val type_real_builder: t
31
  val type_bool_builder: t
32
  val type_string_builder: t
33
  val unify: t -> t -> unit
34
  val is_unifiable: t -> t -> bool
21

  
22
  val pp : Format.formatter -> t -> unit
23

  
24
  val pp_c : Format.formatter -> t -> unit
25

  
26
  val is_scalar_type : t -> bool
27

  
28
  val is_numeric_type : t -> bool
29

  
30
  val is_int_type : t -> bool
31

  
32
  val is_real_type : t -> bool
33

  
34
  val is_bool_type : t -> bool
35

  
36
  val is_dimension_type : t -> bool
37

  
38
  val type_int_builder : t
39

  
40
  val type_real_builder : t
41

  
42
  val type_bool_builder : t
43

  
44
  val type_string_builder : t
45

  
46
  val unify : t -> t -> unit
47

  
48
  val is_unifiable : t -> t -> bool
35 49
end
36 50

  
37
module Basic =
38
struct
39
  type t =
40
    | Tstring
41
    | Tint
42
    | Treal
43
    | Tbool
44
    | Trat (* Actually unused for now. Only place where it can appear is
45
              in a clock declaration *)
51
module Basic = struct
52
  type t = Tstring | Tint | Treal | Tbool | Trat
53
  (* Actually unused for now. Only place where it can appear is in a clock
54
     declaration *)
46 55

  
47 56
  let type_string_builder = Tstring
57

  
48 58
  let type_int_builder = Tint
59

  
49 60
  let type_real_builder = Treal
61

  
50 62
  let type_bool_builder = Tbool
51 63

  
52 64
  open Format
65

  
53 66
  let pp fmt t =
54 67
    match t with
55 68
    | Tint ->
56
       fprintf fmt "int"
69
      fprintf fmt "int"
57 70
    | Treal ->
58
       fprintf fmt "real"
71
      fprintf fmt "real"
59 72
    | Tstring ->
60
       fprintf fmt "string"
73
      fprintf fmt "string"
61 74
    | Tbool ->
62
       fprintf fmt "bool"
75
      fprintf fmt "bool"
63 76
    | Trat ->
64
       fprintf fmt "rat"
77
      fprintf fmt "rat"
65 78

  
66 79
  let pp_c = pp
67
    
68
  let is_scalar_type t =
69
    match t with
70
    | Tbool
71
    | Tint
72
    | Treal -> true
73
    | _ -> false
74 80

  
81
  let is_scalar_type t =
82
    match t with Tbool | Tint | Treal -> true | _ -> false
75 83

  
76
  let is_numeric_type t =
77
    match t with
78
    | Tint
79
    | Treal -> true
80
    | _ -> false
84
  let is_numeric_type t = match t with Tint | Treal -> true | _ -> false
81 85

  
82 86
  let is_int_type t = t = Tint
87

  
83 88
  let is_real_type t = t = Treal
89

  
84 90
  let is_bool_type t = t = Tbool
85 91

  
86
  let is_dimension_type t =
87
    match t with
88
       | Tint
89
 | Tbool -> true
90
 | _ -> false
92
  let is_dimension_type t = match t with Tint | Tbool -> true | _ -> false
91 93

  
92 94
  let is_unifiable b1 b2 = b1 == b2
95

  
93 96
  let unify _ _ = ()
94 97
end
95 98

  
96

  
97
  
98
module Make(BasicT : BASIC_TYPES) =
99
struct
100

  
99
module Make (BasicT : BASIC_TYPES) = struct
101 100
  module BasicT = BasicT
101

  
102 102
  type basic_type = BasicT.t
103
  type type_expr   =
104
    {mutable tdesc: type_desc;
105
     tid: int}
103

  
104
  type type_expr = { mutable tdesc : type_desc; tid : int }
105

  
106 106
  and type_desc =
107
    | Tconst of ident (* type constant *)
107
    | Tconst of ident
108
    (* type constant *)
108 109
    | Tbasic of basic_type
109
    | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
110
    | Tclock of type_expr
111
    (* A type expression explicitely tagged as carrying a clock *)
110 112
    | Tarrow of type_expr * type_expr
111 113
    | Ttuple of type_expr list
112 114
    | Tenum of ident list
113 115
    | Tstruct of (ident * type_expr) list
114 116
    | Tarray of dim_expr * type_expr
115
    | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
116
    | Tlink of type_expr (* During unification, make links instead of substitutions *)
117
    | Tvar (* Monomorphic type variable *)
118
    | Tunivar (* Polymorphic type variable *)
117
    | Tstatic of dim_expr * type_expr
118
    (* a type carried by a dimension expression *)
119
    | Tlink of type_expr
120
    (* During unification, make links instead of substitutions *)
121
    | Tvar
122
    (* Monomorphic type variable *)
123
    | Tunivar
124
  (* Polymorphic type variable *)
119 125

  
120 126
  (*   {mutable tdesc: type_desc; *)
121 127
  (*    tid: int} *)
......
123 129
  (* and type_desc = *)
124 130
  (*   | Tconst of ident (\* type constant *\) *)
125 131
  (*   | Tbasic of BasicT.t *)
126
  (*   | Tclock of type_expr (\* A type expression explicitely tagged as carrying a clock *\) *)
132
  (* | Tclock of type_expr (\* A type expression explicitely tagged as carrying
133
     a clock *\) *)
127 134
  (*   | Tarrow of type_expr * type_expr *)
128 135
  (*   | Ttuple of type_expr list *)
129 136
  (*   | Tenum of ident list *)
130 137
  (*   | Tstruct of (ident * type_expr) list *)
131 138
  (*   | Tarray of dim_expr * type_expr *)
132
  (*   | Tstatic of dim_expr * type_expr (\* a type carried by a dimension expression *\) *)
133
  (*   | Tlink of type_expr (\* During unification, make links instead of substitutions *\) *)
139
  (* | Tstatic of dim_expr * type_expr (\* a type carried by a dimension
140
     expression *\) *)
141
  (* | Tlink of type_expr (\* During unification, make links instead of
142
     substitutions *\) *)
134 143
  (*   | Tvar (\* Monomorphic type variable *\) *)
135 144
  (*   | Tunivar (\* Polymorphic type variable *\) *)
136 145

  
137 146
  type error =
138
      Unbound_value of ident  
147
    | Unbound_value of ident
139 148
    | Already_bound of ident
140 149
    | Already_defined of ident
141 150
    | Undefined_var of ISet.t
......
150 159
    | Type_clash of type_expr * type_expr
151 160
    | Poly_imported_node of ident
152 161

  
153
exception Unify of type_expr * type_expr
154
exception Error of Location.t * error
155

  
156
let mk_basic t = Tbasic t
157

  
158
     
159
(* Pretty-print*)
160
open Format
161

  
162
let rec print_struct_ty_field pp_basic fmt (label, ty) =
163
  fprintf fmt "%a : %a" pp_print_string label (print_ty_param pp_basic) ty
164
and print_ty_param pp_basic fmt ty =
165
  let print_ty = print_ty_param pp_basic in
166
  match ty.tdesc with
167
  | Tvar ->
168
    fprintf fmt "_%s" (name_of_type ty.tid)
169
  | Tbasic t -> pp_basic fmt t
170
  | Tclock t ->
171
    fprintf fmt "%a%s" print_ty t (if !Options.kind2_print then "" else " clock")
172
  | Tstatic (_, t) -> print_ty fmt t
173
                        (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t *)
174
  | Tconst t ->
175
    fprintf fmt "%s" t
176
  | Tarrow (ty1,ty2) ->
177
    fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
178
  | Ttuple tylist ->
179
    fprintf fmt "(%a)"
180
      (Utils.fprintf_list ~sep:" * " print_ty) tylist
181
  | Tenum taglist ->
182
    fprintf fmt "enum {%a }"
183
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
184
  | Tstruct fieldlist ->
185
    fprintf fmt "struct {%a }"
186
      (Utils.fprintf_list ~sep:"; " (print_struct_ty_field pp_basic)) fieldlist
187
  | Tarray (e, ty) ->
188
    fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
189
  | Tlink ty ->
190
    print_ty fmt ty
191
  | Tunivar ->
192
    fprintf fmt "'%s" (name_of_type ty.tid)
193

  
194
let print_ty = print_ty_param BasicT.pp
195
 
196
    
197
let rec print_node_struct_ty_field fmt (label, ty) =
198
  fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
199
and print_node_ty fmt ty =
200
  match ty.tdesc with
201
  | Tvar -> begin
202
    (*Format.eprintf "DEBUG:Types.print_node@.";*)
203
    fprintf fmt "_%s" (name_of_type ty.tid)
204
  end
205
  | Tbasic t -> BasicT.pp fmt t
206
  | Tclock t ->
207
    fprintf fmt "%a%s" print_node_ty t (if !Options.kind2_print then "" else " clock")
208
  | Tstatic (_, t) ->
209
    fprintf fmt "%a" print_node_ty t
210
  | Tconst t ->
211
    fprintf fmt "%s" t
212
  | Tarrow (ty1,ty2) ->
213
    fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
214
  | Ttuple tylist ->
215
    fprintf fmt "(%a)"
216
      (Utils.fprintf_list ~sep:"*" print_node_ty) tylist
217
  | Tenum taglist ->
218
    fprintf fmt "enum {%a }"
219
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
220
  | Tstruct fieldlist ->
221
    fprintf fmt "struct {%a }"
222
      (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist
223
  | Tarray (e, ty) ->
224
    fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e
225
  | Tlink ty ->
162
  exception Unify of type_expr * type_expr
163

  
164
  exception Error of Location.t * error
165

  
166
  let mk_basic t = Tbasic t
167

  
168
  (* Pretty-print*)
169
  open Format
170

  
171
  let rec print_struct_ty_field pp_basic fmt (label, ty) =
172
    fprintf fmt "%a : %a" pp_print_string label (print_ty_param pp_basic) ty
173

  
174
  and print_ty_param pp_basic fmt ty =
175
    let print_ty = print_ty_param pp_basic in
176
    match ty.tdesc with
177
    | Tvar ->
178
      fprintf fmt "_%s" (name_of_type ty.tid)
179
    | Tbasic t ->
180
      pp_basic fmt t
181
    | Tclock t ->
182
      fprintf fmt "%a%s" print_ty t
183
        (if !Options.kind2_print then "" else " clock")
184
    | Tstatic (_, t) ->
185
      print_ty fmt t
186
    (* fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t *)
187
    | Tconst t ->
188
      fprintf fmt "%s" t
189
    | Tarrow (ty1, ty2) ->
190
      fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
191
    | Ttuple tylist ->
192
      fprintf fmt "(%a)" (Utils.fprintf_list ~sep:" * " print_ty) tylist
193
    | Tenum taglist ->
194
      fprintf fmt "enum {%a }"
195
        (Utils.fprintf_list ~sep:", " pp_print_string)
196
        taglist
197
    | Tstruct fieldlist ->
198
      fprintf fmt "struct {%a }"
199
        (Utils.fprintf_list ~sep:"; " (print_struct_ty_field pp_basic))
200
        fieldlist
201
    | Tarray (e, ty) ->
202
      fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
203
    | Tlink ty ->
204
      print_ty fmt ty
205
    | Tunivar ->
206
      fprintf fmt "'%s" (name_of_type ty.tid)
207

  
208
  let print_ty = print_ty_param BasicT.pp
209

  
210
  let rec print_node_struct_ty_field fmt (label, ty) =
211
    fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
212

  
213
  and print_node_ty fmt ty =
214
    match ty.tdesc with
215
    | Tvar ->
216
      (*Format.eprintf "DEBUG:Types.print_node@.";*)
217
      fprintf fmt "_%s" (name_of_type ty.tid)
218
    | Tbasic t ->
219
      BasicT.pp fmt t
220
    | Tclock t ->
221
      fprintf fmt "%a%s" print_node_ty t
222
        (if !Options.kind2_print then "" else " clock")
223
    | Tstatic (_, t) ->
224
      fprintf fmt "%a" print_node_ty t
225
    | Tconst t ->
226
      fprintf fmt "%s" t
227
    | Tarrow (ty1, ty2) ->
228
      fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
229
    | Ttuple tylist ->
230
      fprintf fmt "(%a)" (Utils.fprintf_list ~sep:"*" print_node_ty) tylist
231
    | Tenum taglist ->
232
      fprintf fmt "enum {%a }"
233
        (Utils.fprintf_list ~sep:", " pp_print_string)
234
        taglist
235
    | Tstruct fieldlist ->
236
      fprintf fmt "struct {%a }"
237
        (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field)
238
        fieldlist
239
    | Tarray (e, ty) ->
240
      fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e
241
    | Tlink ty ->
226 242
      print_node_ty fmt ty
227
  | Tunivar ->
228
    fprintf fmt "'%s" (name_of_type ty.tid)
229

  
230
let pp_error fmt = function
231
  | Unbound_value id ->
232
    fprintf fmt "Unknown value %s@." id
233
  | Unbound_type id ->
234
    fprintf fmt "Unknown type %s@." id
235
  | Already_bound id ->
236
    fprintf fmt "%s is already declared@." id
237
  | Already_defined id ->
238
    fprintf fmt "Multiple definitions of variable %s@." id
239
  | Not_a_constant ->
240
    fprintf fmt "This expression is not a constant@."
241
  | Assigned_constant id ->
242
    fprintf fmt "The constant %s cannot be assigned@." id
243
  | Not_a_dimension ->
244
    fprintf fmt "This expression is not a valid dimension@."
245
  | WrongArity (ar1, ar2) ->
246
    fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
247
  | WrongMorphism (ar1, ar2) ->
248
    fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
249
  | Type_mismatch id ->
250
    fprintf fmt "Definition and declaration of type %s don't agree@." id
251
  | Undefined_var vset ->
252
    fprintf fmt "No definition provided for variable(s): %a@."
253
      (Utils.fprintf_list ~sep:"," pp_print_string)
254
      (ISet.elements vset)
255
  | Declared_but_undefined id ->
256
     fprintf fmt "%s is declared but not defined@." id
257
  | Type_clash (ty1,ty2) ->
243
    | Tunivar ->
244
      fprintf fmt "'%s" (name_of_type ty.tid)
245

  
246
  let pp_error fmt = function
247
    | Unbound_value id ->
248
      fprintf fmt "Unknown value %s@." id
249
    | Unbound_type id ->
250
      fprintf fmt "Unknown type %s@." id
251
    | Already_bound id ->
252
      fprintf fmt "%s is already declared@." id
253
    | Already_defined id ->
254
      fprintf fmt "Multiple definitions of variable %s@." id
255
    | Not_a_constant ->
256
      fprintf fmt "This expression is not a constant@."
257
    | Assigned_constant id ->
258
      fprintf fmt "The constant %s cannot be assigned@." id
259
    | Not_a_dimension ->
260
      fprintf fmt "This expression is not a valid dimension@."
261
    | WrongArity (ar1, ar2) ->
262
      fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
263
    | WrongMorphism (ar1, ar2) ->
264
      fprintf fmt
265
        "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
266
    | Type_mismatch id ->
267
      fprintf fmt "Definition and declaration of type %s don't agree@." id
268
    | Undefined_var vset ->
269
      fprintf fmt "No definition provided for variable(s): %a@."
270
        (Utils.fprintf_list ~sep:"," pp_print_string)
271
        (ISet.elements vset)
272
    | Declared_but_undefined id ->
273
      fprintf fmt "%s is declared but not defined@." id
274
    | Type_clash (ty1, ty2) ->
258 275
      Utils.reset_names ();
259
    fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
260
  | Poly_imported_node _ ->
261
    fprintf fmt "Imported nodes cannot have a polymorphic type@."
262

  
263

  
264
let new_id = ref (-1)
265

  
266
let rec bottom =
267
  { tdesc = Tlink bottom; tid = -666 }
268

  
269
let new_ty desc =
270
  incr new_id; {tdesc = desc; tid = !new_id }
271

  
272
let new_var () =
273
  new_ty Tvar
274

  
275
let new_univar () =
276
  new_ty Tunivar
277

  
278
let rec repr =
279
  function
280
    {tdesc = Tlink t'; _} ->
281
      repr t'
282
  | t -> t
283

  
284
let get_static_value ty =
285
  match (repr ty).tdesc with
286
  | Tstatic (d, _) -> Some d
287
  | _              -> None
288

  
289
let get_field_type ty label =
290
  match (repr ty).tdesc with
291
  | Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
292
  | _          -> None
293

  
294
let is_static_type ty =
295
  match (repr ty).tdesc with
296
  | Tstatic _ -> true
297
  | _         -> false
298

  
299
let rec is_scalar_type ty =
300
  match (repr ty).tdesc with
301
  | Tstatic (_, ty) -> is_scalar_type ty
302
  | Tbasic t -> BasicT.is_scalar_type t
303
  | _     -> false
304

  
305
let rec is_numeric_type ty =
306
 match (repr ty).tdesc with
307
 | Tstatic (_, ty) -> is_numeric_type ty
308
 | Tbasic t -> BasicT.is_numeric_type t
309
 | _     -> false
310
    
311
let rec is_real_type ty =
312
 match (repr ty).tdesc with
313
 | Tstatic (_, ty) -> is_real_type ty
314
 | Tbasic t -> BasicT.is_real_type t
315
 | _     -> false
316

  
317
let rec is_int_type ty =
318
 match (repr ty).tdesc with
319
 | Tstatic (_, ty) -> is_int_type ty
320
 | Tbasic t -> BasicT.is_int_type t
321
 | _     -> false
322

  
323
let rec is_bool_type ty =
324
 match (repr ty).tdesc with
325
 | Tstatic (_, ty) -> is_bool_type ty
326
 | Tbasic t -> BasicT.is_bool_type t
327
 | _     -> false
328

  
329
let rec is_const_type ty c =
330
  match (repr ty).tdesc with
331
  | Tstatic (_, ty) -> is_const_type ty c
332
  | Tconst c' -> c = c'
333
  | _     -> false
334

  
335
let get_clock_base_type ty =
336
 match (repr ty).tdesc with
337
 | Tclock ty -> Some ty
338
 | _         -> None
339

  
340
let unclock_type ty =
341
  let ty = repr ty in
342
  match ty.tdesc with
343
  | Tclock ty' -> ty'
344
  | _          -> ty
345

  
346
let rec is_dimension_type ty =
347
 match (repr ty).tdesc with
348
 | Tbasic t -> BasicT.is_dimension_type t
349
 | Tclock ty'
350
 | Tstatic (_, ty') -> is_dimension_type ty'
351
 | _                -> false
352

  
353
let dynamic_type ty =
354
  let ty = repr ty in
355
  match ty.tdesc with
356
  | Tstatic (_, ty') -> ty'
357
  | _                -> ty
358

  
359
let is_tuple_type ty =
360
 match (repr ty).tdesc with
361
 | Ttuple _         -> true
362
 | _                -> false
363

  
364
let map_tuple_type f ty =
365
  let ty = dynamic_type ty in
366
  match ty.tdesc with
367
  | (Ttuple ty_list) -> { ty with tdesc = Ttuple (List.map f ty_list) }
368
  | _                -> f ty
369

  
370
let rec is_struct_type ty =
371
 match (repr ty).tdesc with
372
 | Tstruct _        -> true
373
 | Tstatic (_, ty') -> is_struct_type ty'
374
 | _                -> false
375

  
376
let struct_field_type ty field =
377
  match (dynamic_type ty).tdesc with
378
  | Tstruct fields ->
379
    (try
380
       List.assoc field fields
381
     with Not_found -> assert false)
382
  | _              -> assert false
383

  
384
let rec is_array_type ty =
385
 match (repr ty).tdesc with
386
 | Tarray _         -> true
387
 | Tstatic (_, ty') -> is_array_type ty' (* looks strange !? *)
388
 | _                -> false
389

  
390
let array_type_dimension ty =
391
  match (dynamic_type ty).tdesc with
392
  | Tarray (d, _) -> d
393
  | _             -> (Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty ty; assert false)
394

  
395
let rec array_type_multi_dimension ty =
396
  match (dynamic_type ty).tdesc with
397
  | Tarray (d, ty') -> d :: array_type_multi_dimension ty'
398
  | _               -> []
399

  
400
let array_element_type ty =
401
  match (dynamic_type ty).tdesc with
402
  | Tarray (_, ty') -> ty'
403
  | _               -> (Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty; assert false)
404

  
405
let rec array_base_type ty =
406
  let ty = repr ty in
407
  match ty.tdesc with
408
  | Tarray (_, ty')
409
  | Tstatic (_, ty') -> array_base_type ty'
410
  | _                -> ty
411

  
412
let is_address_type ty =
413
  is_array_type ty || is_struct_type ty || (is_real_type ty && !Options.mpfr)
414

  
415
let rec is_generic_type ty =
416
 match (dynamic_type ty).tdesc with
417
  | Tarray (d, ty') ->
418
    (not (Dimension.is_dimension_const d)) || (is_generic_type ty')
419
  | _               -> false
420

  
421
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
422
    (ensured by language syntax) *)
423
let rec split_arrow ty =
424
  match (repr ty).tdesc with
425
  | Tarrow (tin,tout) -> tin,tout
426
  | Tstatic (_, ty')  -> split_arrow ty'
427
    (* Functions are not first order, I don't think the var case
428
       needs to be considered here *)
429
  | _ -> Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty; assert false
430

  
431
(** Returns the type corresponding to a type list. *)
432
let type_of_type_list tyl =
433
  if (List.length tyl) > 1 then
434
    new_ty (Ttuple tyl)
435
  else
436
    List.hd tyl
437

  
438
let rec type_list_of_type ty =
439
 match (repr ty).tdesc with
440
 | Tstatic (_, ty) -> type_list_of_type ty
441
 | Ttuple tl       -> tl
442
 | _               -> [ty]
443

  
444
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
445
let rec is_polymorphic ty =
446
  match ty.tdesc with
447
  | Tenum _ | Tvar | Tbasic _ | Tconst _ -> false
448
  | Tclock ty -> is_polymorphic ty
449
  | Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2)
450
  | Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl
451
  | Tstruct fl -> List.exists (fun (_, t) -> is_polymorphic t) fl
452
  | Tlink t' -> is_polymorphic t'
453
  | Tarray (d, ty)
454
  | Tstatic (d, ty) -> Dimension.is_polymorphic d || is_polymorphic ty
455
  | Tunivar -> true
456

  
457

  
458
let mktyptuple nb typ =
459
  let array = Array.make nb typ in
460
  Ttuple (Array.to_list array)
461

  
462
let type_desc t = t.tdesc
463

  
464

  
465

  
466
let type_int = mk_basic BasicT.type_int_builder
467
let type_real = mk_basic BasicT.type_real_builder
468
let type_bool = mk_basic BasicT.type_bool_builder
469
let type_string = mk_basic BasicT.type_string_builder
470
    
276
      fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
277
    | Poly_imported_node _ ->
278
      fprintf fmt "Imported nodes cannot have a polymorphic type@."
279

  
280
  let new_id = ref (-1)
281

  
282
  let rec bottom = { tdesc = Tlink bottom; tid = -666 }
283

  
284
  let new_ty desc =
285
    incr new_id;
286
    { tdesc = desc; tid = !new_id }
287

  
288
  let new_var () = new_ty Tvar
289

  
290
  let new_univar () = new_ty Tunivar
291

  
292
  let rec repr = function { tdesc = Tlink t'; _ } -> repr t' | t -> t
293

  
294
  let get_static_value ty =
295
    match (repr ty).tdesc with Tstatic (d, _) -> Some d | _ -> None
296

  
297
  let get_field_type ty label =
298
    match (repr ty).tdesc with
299
    | Tstruct fl -> (
300
      try Some (List.assoc label fl) with Not_found -> None)
301
    | _ ->
302
      None
303

  
304
  let is_static_type ty =
305
    match (repr ty).tdesc with Tstatic _ -> true | _ -> false
306

  
307
  let rec is_scalar_type ty =
308
    match (repr ty).tdesc with
309
    | Tstatic (_, ty) ->
310
      is_scalar_type ty
311
    | Tbasic t ->
312
      BasicT.is_scalar_type t
313
    | _ ->
314
      false
315

  
316
  let rec is_numeric_type ty =
317
    match (repr ty).tdesc with
318
    | Tstatic (_, ty) ->
319
      is_numeric_type ty
320
    | Tbasic t ->
321
      BasicT.is_numeric_type t
322
    | _ ->
323
      false
324

  
325
  let rec is_real_type ty =
326
    match (repr ty).tdesc with
327
    | Tstatic (_, ty) ->
328
      is_real_type ty
329
    | Tbasic t ->
330
      BasicT.is_real_type t
331
    | _ ->
332
      false
333

  
334
  let rec is_int_type ty =
335
    match (repr ty).tdesc with
336
    | Tstatic (_, ty) ->
337
      is_int_type ty
338
    | Tbasic t ->
339
      BasicT.is_int_type t
340
    | _ ->
341
      false
342

  
343
  let rec is_bool_type ty =
344
    match (repr ty).tdesc with
345
    | Tstatic (_, ty) ->
346
      is_bool_type ty
347
    | Tbasic t ->
348
      BasicT.is_bool_type t
349
    | _ ->
350
      false
351

  
352
  let rec is_const_type ty c =
353
    match (repr ty).tdesc with
354
    | Tstatic (_, ty) ->
355
      is_const_type ty c
356
    | Tconst c' ->
357
      c = c'
358
    | _ ->
359
      false
360

  
361
  let get_clock_base_type ty =
362
    match (repr ty).tdesc with Tclock ty -> Some ty | _ -> None
363

  
364
  let unclock_type ty =
365
    let ty = repr ty in
366
    match ty.tdesc with Tclock ty' -> ty' | _ -> ty
367

  
368
  let rec is_dimension_type ty =
369
    match (repr ty).tdesc with
370
    | Tbasic t ->
371
      BasicT.is_dimension_type t
372
    | Tclock ty' | Tstatic (_, ty') ->
373
      is_dimension_type ty'
374
    | _ ->
375
      false
376

  
377
  let dynamic_type ty =
378
    let ty = repr ty in
379
    match ty.tdesc with Tstatic (_, ty') -> ty' | _ -> ty
380

  
381
  let is_tuple_type ty =
382
    match (repr ty).tdesc with Ttuple _ -> true | _ -> false
383

  
384
  let map_tuple_type f ty =
385
    let ty = dynamic_type ty in
386
    match ty.tdesc with
387
    | Ttuple ty_list ->
388
      { ty with tdesc = Ttuple (List.map f ty_list) }
389
    | _ ->
390
      f ty
391

  
392
  let rec is_struct_type ty =
393
    match (repr ty).tdesc with
394
    | Tstruct _ ->
395
      true
396
    | Tstatic (_, ty') ->
397
      is_struct_type ty'
398
    | _ ->
399
      false
400

  
401
  let struct_field_type ty field =
402
    match (dynamic_type ty).tdesc with
403
    | Tstruct fields -> (
404
      try List.assoc field fields with Not_found -> assert false)
405
    | _ ->
406
      assert false
407

  
408
  let rec is_array_type ty =
409
    match (repr ty).tdesc with
410
    | Tarray _ ->
411
      true
412
    | Tstatic (_, ty') ->
413
      is_array_type ty' (* looks strange !? *)
414
    | _ ->
415
      false
416

  
417
  let array_type_dimension ty =
418
    match (dynamic_type ty).tdesc with
419
    | Tarray (d, _) ->
420
      d
421
    | _ ->
422
      Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty
423
        ty;
424
      assert false
425

  
426
  let rec array_type_multi_dimension ty =
427
    match (dynamic_type ty).tdesc with
428
    | Tarray (d, ty') ->
429
      d :: array_type_multi_dimension ty'
430
    | _ ->
431
      []
432

  
433
  let array_element_type ty =
434
    match (dynamic_type ty).tdesc with
435
    | Tarray (_, ty') ->
436
      ty'
437
    | _ ->
438
      Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty;
439
      assert false
440

  
441
  let rec array_base_type ty =
442
    let ty = repr ty in
443
    match ty.tdesc with
444
    | Tarray (_, ty') | Tstatic (_, ty') ->
445
      array_base_type ty'
446
    | _ ->
447
      ty
448

  
449
  let is_address_type ty =
450
    is_array_type ty || is_struct_type ty || (is_real_type ty && !Options.mpfr)
451

  
452
  let rec is_generic_type ty =
453
    match (dynamic_type ty).tdesc with
454
    | Tarray (d, ty') ->
455
      (not (Dimension.is_dimension_const d)) || is_generic_type ty'
456
    | _ ->
457
      false
458

  
459
  (** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
460
      (ensured by language syntax) *)
461
  let rec split_arrow ty =
462
    match (repr ty).tdesc with
463
    | Tarrow (tin, tout) ->
464
      tin, tout
465
    | Tstatic (_, ty') ->
466
      split_arrow ty'
467
    (* Functions are not first order, I don't think the var case needs to be
468
       considered here *)
469
    | _ ->
470
      Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty;
471
      assert false
472

  
473
  (** Returns the type corresponding to a type list. *)
474
  let type_of_type_list tyl =
475
    if List.length tyl > 1 then new_ty (Ttuple tyl) else List.hd tyl
476

  
477
  let rec type_list_of_type ty =
478
    match (repr ty).tdesc with
479
    | Tstatic (_, ty) ->
480
      type_list_of_type ty
481
    | Ttuple tl ->
482
      tl
483
    | _ ->
484
      [ ty ]
485

  
486
  (** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
487
  let rec is_polymorphic ty =
488
    match ty.tdesc with
489
    | Tenum _ | Tvar | Tbasic _ | Tconst _ ->
490
      false
491
    | Tclock ty ->
492
      is_polymorphic ty
493
    | Tarrow (ty1, ty2) ->
494
      is_polymorphic ty1 || is_polymorphic ty2
495
    | Ttuple tl ->
496
      List.exists (fun t -> is_polymorphic t) tl
497
    | Tstruct fl ->
498
      List.exists (fun (_, t) -> is_polymorphic t) fl
499
    | Tlink t' ->
500
      is_polymorphic t'
501
    | Tarray (d, ty) | Tstatic (d, ty) ->
502
      Dimension.is_polymorphic d || is_polymorphic ty
503
    | Tunivar ->
504
      true
505

  
506
  let mktyptuple nb typ =
507
    let array = Array.make nb typ in
508
    Ttuple (Array.to_list array)
509

  
510
  let type_desc t = t.tdesc
511

  
512
  let type_int = mk_basic BasicT.type_int_builder
513

  
514
  let type_real = mk_basic BasicT.type_real_builder
515

  
516
  let type_bool = mk_basic BasicT.type_bool_builder
517

  
518
  let type_string = mk_basic BasicT.type_string_builder
471 519
end
472 520

  
521
module type S = sig
522
  module BasicT : BASIC_TYPES
473 523

  
474
module type S = 
475
sig
476
  module BasicT: BASIC_TYPES 
477 524
  type basic_type = BasicT.t
478
  type type_expr   =
479
    {mutable tdesc: type_desc;
480
     tid: int}
525

  
526
  type type_expr = { mutable tdesc : type_desc; tid : int }
527

  
481 528
  and type_desc =
482
    | Tconst of ident (* type constant *)
529
    | Tconst of ident
530
    (* type constant *)
483 531
    | Tbasic of basic_type
484
    | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
532
    | Tclock of type_expr
533
    (* A type expression explicitely tagged as carrying a clock *)
485 534
    | Tarrow of type_expr * type_expr
486 535
    | Ttuple of type_expr list
487 536
    | Tenum of ident list
488 537
    | Tstruct of (ident * type_expr) list
489 538
    | Tarray of dim_expr * type_expr
490
    | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
491
    | Tlink of type_expr (* During unification, make links instead of substitutions *)
492
    | Tvar (* Monomorphic type variable *)
493
    | Tunivar (* Polymorphic type variable *)
539
    | Tstatic of dim_expr * type_expr
540
    (* a type carried by a dimension expression *)
541
    | Tlink of type_expr
542
    (* During unification, make links instead of substitutions *)
543
    | Tvar
544
    (* Monomorphic type variable *)
545
    | Tunivar
546
  (* Polymorphic type variable *)
494 547

  
495 548
  type error =
496
      Unbound_value of ident  
549
    | Unbound_value of ident
497 550
    | Already_bound of ident
498 551
    | Already_defined of ident
499 552
    | Undefined_var of ISet.t
......
508 561
    | Type_clash of type_expr * type_expr
509 562
    | Poly_imported_node of ident
510 563

  
511
	  exception Unify of type_expr * type_expr
512
	  exception Error of Location.t * error
513

  
514
  val is_real_type: type_expr -> bool
515
  val is_int_type: type_expr -> bool
516
  val is_bool_type: type_expr -> bool
517
  val is_const_type: type_expr -> ident -> bool
518
  val is_static_type: type_expr -> bool
519
  val is_array_type: type_expr -> bool
520
  val is_dimension_type: type_expr -> bool
521
  val is_address_type: type_expr -> bool
522
  val is_generic_type: type_expr -> bool
523
  val print_ty: Format.formatter -> type_expr -> unit
524
  val repr: type_expr -> type_expr
525
  val dynamic_type: type_expr -> type_expr
526
  val type_desc: type_expr -> type_desc
527
  val new_var: unit -> type_expr
528
  val new_univar: unit -> type_expr
529
  val new_ty: type_desc -> type_expr
530
  val type_int: type_desc
531
  val type_real: type_desc
532
  val type_bool: type_desc
533
  val type_string: type_desc
534
  val array_element_type: type_expr -> type_expr
535
  val type_list_of_type: type_expr -> type_expr list
536
  val print_node_ty: Format.formatter -> type_expr -> unit
537
  val get_clock_base_type: type_expr -> type_expr option
538
  val get_static_value: type_expr -> Dimension.dim_expr option
539
  val is_tuple_type: type_expr -> bool
540
  val type_of_type_list: type_expr list -> type_expr
541
  val split_arrow: type_expr -> type_expr * type_expr
542
  val unclock_type: type_expr -> type_expr
543
  val bottom: type_expr
544
  val map_tuple_type: (type_expr -> type_expr) -> type_expr -> type_expr
545
  val array_base_type: type_expr -> type_expr
546
  val array_type_dimension: type_expr -> Dimension.dim_expr
547
  val pp_error: Format.formatter -> error -> unit
548
  val struct_field_type: type_expr -> ident -> type_expr
549
  val array_type_multi_dimension: type_expr -> Dimension.dim_expr list
550
end (* with type type_expr = BasicT.t type_expr_gen *)
551

  
552
module type Sbasic = S with type BasicT.t = Basic.t 
553
  
564
  exception Unify of type_expr * type_expr
565

  
566
  exception Error of Location.t * error
567

  
568
  val is_real_type : type_expr -> bool
569

  
570
  val is_int_type : type_expr -> bool
571

  
572
  val is_bool_type : type_expr -> bool
573

  
574
  val is_const_type : type_expr -> ident -> bool
575

  
576
  val is_static_type : type_expr -> bool
577

  
578
  val is_array_type : type_expr -> bool
579

  
580
  val is_dimension_type : type_expr -> bool
581

  
582
  val is_address_type : type_expr -> bool
583

  
584
  val is_generic_type : type_expr -> bool
585

  
586
  val print_ty : Format.formatter -> type_expr -> unit
587

  
588
  val repr : type_expr -> type_expr
589

  
590
  val dynamic_type : type_expr -> type_expr
591

  
592
  val type_desc : type_expr -> type_desc
593

  
594
  val new_var : unit -> type_expr
595

  
596
  val new_univar : unit -> type_expr
597

  
598
  val new_ty : type_desc -> type_expr
599

  
600
  val type_int : type_desc
601

  
602
  val type_real : type_desc
603

  
604
  val type_bool : type_desc
605

  
606
  val type_string : type_desc
607

  
608
  val array_element_type : type_expr -> type_expr
609

  
610
  val type_list_of_type : type_expr -> type_expr list
611

  
612
  val print_node_ty : Format.formatter -> type_expr -> unit
613

  
614
  val get_clock_base_type : type_expr -> type_expr option
615

  
616
  val get_static_value : type_expr -> Dimension.dim_expr option
617

  
618
  val is_tuple_type : type_expr -> bool
619

  
620
  val type_of_type_list : type_expr list -> type_expr
621

  
622
  val split_arrow : type_expr -> type_expr * type_expr
623

  
624
  val unclock_type : type_expr -> type_expr
625

  
626
  val bottom : type_expr
627

  
628
  val map_tuple_type : (type_expr -> type_expr) -> type_expr -> type_expr
629

  
630
  val array_base_type : type_expr -> type_expr
631

  
632
  val array_type_dimension : type_expr -> Dimension.dim_expr
633

  
634
  val pp_error : Format.formatter -> error -> unit
635

  
636
  val struct_field_type : type_expr -> ident -> type_expr
637

  
638
  val array_type_multi_dimension : type_expr -> Dimension.dim_expr list
639
end
640
(* with type type_expr = BasicT.t type_expr_gen *)
641

  
642
module type Sbasic = S with type BasicT.t = Basic.t
643

  
554 644
module Main : Sbasic = Make (Basic)
555
include Main 
556 645

  
646
include Main
557 647

  
558 648
(* Local Variables: *)
559 649
(* compile-command:"make -C .." *)

Also available in: Unified diff