Project

General

Profile

Download (17.2 KB) Statistics
| Branch: | Tag: | Revision:
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
open Utils
15
(** Types definitions and a few utility functions on types. *)
16

    
17
open Dimension
18

    
19
module type BASIC_TYPES = sig
20
  type t
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
49
end
50

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

    
56
  let type_string_builder = Tstring
57

    
58
  let type_int_builder = Tint
59

    
60
  let type_real_builder = Treal
61

    
62
  let type_bool_builder = Tbool
63

    
64
  open Format
65

    
66
  let pp fmt t =
67
    match t with
68
    | Tint ->
69
      fprintf fmt "int"
70
    | Treal ->
71
      fprintf fmt "real"
72
    | Tstring ->
73
      fprintf fmt "string"
74
    | Tbool ->
75
      fprintf fmt "bool"
76
    | Trat ->
77
      fprintf fmt "rat"
78

    
79
  let pp_c = pp
80

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

    
84
  let is_numeric_type t = match t with Tint | Treal -> true | _ -> false
85

    
86
  let is_int_type t = t = Tint
87

    
88
  let is_real_type t = t = Treal
89

    
90
  let is_bool_type t = t = Tbool
91

    
92
  let is_dimension_type t = match t with Tint | Tbool -> true | _ -> false
93

    
94
  let is_unifiable b1 b2 = b1 == b2
95

    
96
  let unify _ _ = ()
97
end
98

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

    
102
  type basic_type = BasicT.t
103

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

    
106
  and type_desc =
107
    | Tconst of ident
108
    (* type constant *)
109
    | Tbasic of basic_type
110
    | Tclock of type_expr
111
    (* A type expression explicitely tagged as carrying a clock *)
112
    | Tarrow of type_expr * type_expr
113
    | Ttuple of type_expr list
114
    | Tenum of ident list
115
    | Tstruct of (ident * type_expr) list
116
    | Tarray of dim_expr * type_expr
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 *)
125

    
126
  (*   {mutable tdesc: type_desc; *)
127
  (*    tid: int} *)
128

    
129
  (* and type_desc = *)
130
  (*   | Tconst of ident (\* type constant *\) *)
131
  (*   | Tbasic of BasicT.t *)
132
  (* | Tclock of type_expr (\* A type expression explicitely tagged as carrying
133
     a clock *\) *)
134
  (*   | Tarrow of type_expr * type_expr *)
135
  (*   | Ttuple of type_expr list *)
136
  (*   | Tenum of ident list *)
137
  (*   | Tstruct of (ident * type_expr) list *)
138
  (*   | Tarray of dim_expr * type_expr *)
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 *\) *)
143
  (*   | Tvar (\* Monomorphic type variable *\) *)
144
  (*   | Tunivar (\* Polymorphic type variable *\) *)
145

    
146
  type error =
147
    | Unbound_value of ident
148
    | Already_bound of ident
149
    | Already_defined of ident
150
    | Undefined_var of ISet.t
151
    | Declared_but_undefined of ident
152
    | Unbound_type of ident
153
    | Not_a_dimension
154
    | Not_a_constant
155
    | Assigned_constant of ident
156
    | WrongArity of int * int
157
    | WrongMorphism of int * int
158
    | Type_mismatch of ident
159
    | Type_clash of type_expr * type_expr
160
    | Poly_imported_node of ident
161

    
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 ->
242
      print_node_ty fmt ty
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) ->
275
      Utils.reset_names ();
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
519
end
520

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

    
524
  type basic_type = BasicT.t
525

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

    
528
  and type_desc =
529
    | Tconst of ident
530
    (* type constant *)
531
    | Tbasic of basic_type
532
    | Tclock of type_expr
533
    (* A type expression explicitely tagged as carrying a clock *)
534
    | Tarrow of type_expr * type_expr
535
    | Ttuple of type_expr list
536
    | Tenum of ident list
537
    | Tstruct of (ident * type_expr) list
538
    | Tarray of dim_expr * type_expr
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 *)
547

    
548
  type error =
549
    | Unbound_value of ident
550
    | Already_bound of ident
551
    | Already_defined of ident
552
    | Undefined_var of ISet.t
553
    | Declared_but_undefined of ident
554
    | Unbound_type of ident
555
    | Not_a_dimension
556
    | Not_a_constant
557
    | Assigned_constant of ident
558
    | WrongArity of int * int
559
    | WrongMorphism of int * int
560
    | Type_mismatch of ident
561
    | Type_clash of type_expr * type_expr
562
    | Poly_imported_node of ident
563

    
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

    
644
module Main : Sbasic = Make (Basic)
645

    
646
include Main
647

    
648
(* Local Variables: *)
649
(* compile-command:"make -C .." *)
650
(* End: *)
(61-61/66)