Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / types.ml @ master

History | View | Annotate | Download (16.5 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
module type BASIC_TYPES =
19
sig
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
35
end
36

    
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 *)
46

    
47
  let type_string_builder = Tstring
48
  let type_int_builder = Tint
49
  let type_real_builder = Treal
50
  let type_bool_builder = Tbool
51

    
52
  open Format
53
  let pp fmt t =
54
    match t with
55
    | Tint ->
56
       fprintf fmt "int"
57
    | Treal ->
58
       fprintf fmt "real"
59
    | Tstring ->
60
       fprintf fmt "string"
61
    | Tbool ->
62
       fprintf fmt "bool"
63
    | Trat ->
64
       fprintf fmt "rat"
65

    
66
  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

    
75

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

    
82
  let is_int_type t = t = Tint
83
  let is_real_type t = t = Treal
84
  let is_bool_type t = t = Tbool
85

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

    
92
  let is_unifiable b1 b2 = b1 == b2
93
  let unify _ _ = ()
94
end
95

    
96

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

    
101
  module BasicT = BasicT
102
  type basic_type = BasicT.t
103
  type type_expr   =
104
    {mutable tdesc: type_desc;
105
     tid: int}
106
  and type_desc =
107
    | Tconst of ident (* type constant *)
108
    | Tbasic of basic_type
109
    | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
110
    | Tarrow of type_expr * type_expr
111
    | Ttuple of type_expr list
112
    | Tenum of ident list
113
    | Tstruct of (ident * type_expr) list
114
    | 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 *)
119

    
120
  (*   {mutable tdesc: type_desc; *)
121
  (*    tid: int} *)
122

    
123
  (* and type_desc = *)
124
  (*   | Tconst of ident (\* type constant *\) *)
125
  (*   | Tbasic of BasicT.t *)
126
  (*   | Tclock of type_expr (\* A type expression explicitely tagged as carrying a clock *\) *)
127
  (*   | Tarrow of type_expr * type_expr *)
128
  (*   | Ttuple of type_expr list *)
129
  (*   | Tenum of ident list *)
130
  (*   | Tstruct of (ident * type_expr) list *)
131
  (*   | 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 *\) *)
134
  (*   | Tvar (\* Monomorphic type variable *\) *)
135
  (*   | Tunivar (\* Polymorphic type variable *\) *)
136

    
137
  type error =
138
      Unbound_value of ident  
139
    | Already_bound of ident
140
    | Already_defined of ident
141
    | Undefined_var of ISet.t
142
    | Declared_but_undefined of ident
143
    | Unbound_type of ident
144
    | Not_a_dimension
145
    | Not_a_constant
146
    | Assigned_constant of ident
147
    | WrongArity of int * int
148
    | WrongMorphism of int * int
149
    | Type_mismatch of ident
150
    | Type_clash of type_expr * type_expr
151
    | Poly_imported_node of ident
152

    
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 clock" print_ty t
172
  | Tstatic (d, 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 clock" print_node_ty t
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 ->
226
      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) ->
258
      Utils.reset_names ();
259
    fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2
260
  | Poly_imported_node id ->
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 rec is_static_type ty =
295
  match (repr ty).tdesc with
296
  | Tstatic (_, ty) -> 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
    
471
end
472

    
473

    
474
module type S = 
475
sig
476
  module BasicT: BASIC_TYPES 
477
  type basic_type = BasicT.t
478
  type type_expr   =
479
    {mutable tdesc: type_desc;
480
     tid: int}
481
  and type_desc =
482
    | Tconst of ident (* type constant *)
483
    | Tbasic of basic_type
484
    | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
485
    | Tarrow of type_expr * type_expr
486
    | Ttuple of type_expr list
487
    | Tenum of ident list
488
    | Tstruct of (ident * type_expr) list
489
    | 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 *)
494

    
495
  type error =
496
      Unbound_value of ident  
497
    | Already_bound of ident
498
    | Already_defined of ident
499
    | Undefined_var of ISet.t
500
    | Declared_but_undefined of ident
501
    | Unbound_type of ident
502
    | Not_a_dimension
503
    | Not_a_constant
504
    | Assigned_constant of ident
505
    | WrongArity of int * int
506
    | WrongMorphism of int * int
507
    | Type_mismatch of ident
508
    | Type_clash of type_expr * type_expr
509
    | Poly_imported_node of ident
510

    
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
  
554
module Main : Sbasic = Make (Basic)
555
include Main 
556

    
557

    
558
(* Local Variables: *)
559
(* compile-command:"make -C .." *)
560
(* End: *)