Project

General

Profile

Revision 66359a5e src/types.ml

View differences:

src/types.ml
15 15
open Utils
16 16
open Dimension
17 17

  
18
type type_expr =
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   =
19 104
    {mutable tdesc: type_desc;
20 105
     tid: int}
21

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

  
40
type error =
41
    Unbound_value of ident  
42
  | Already_bound of ident
43
  | Already_defined of ident
44
  | Undefined_var of ISet.t
45
  | Declared_but_undefined of ident
46
  | Unbound_type of ident
47
  | Not_a_dimension
48
  | Not_a_constant
49
  | Assigned_constant of ident
50
  | WrongArity of int * int
51
  | WrongMorphism of int * int
52
  | Type_mismatch of ident
53
  | Type_clash of type_expr * type_expr
54
  | Poly_imported_node of ident
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
55 152

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

  
156
let mk_basic t = Tbasic t
157

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

  
62
let rec print_struct_ty_field fmt (label, ty) =
63
  fprintf fmt "%a : %a" pp_print_string label print_ty ty
64
and print_ty fmt ty =
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
65 166
  match ty.tdesc with
66 167
  | Tvar ->
67 168
    fprintf fmt "_%s" (name_of_type ty.tid)
68
  | Tint ->
69
    fprintf fmt "int"
70
  | Treal ->
71
    fprintf fmt "real"
72
  | Tbool ->
73
    fprintf fmt "bool"
169
  | Tbasic t -> pp_basic fmt t
74 170
  | Tclock t ->
75 171
    fprintf fmt "%a clock" print_ty t
76 172
  | Tstatic (d, t) ->
77 173
    fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t
78 174
  | Tconst t ->
79 175
    fprintf fmt "%s" t
80
  | Trat ->
81
    fprintf fmt "rat"
82 176
  | Tarrow (ty1,ty2) ->
83 177
    fprintf fmt "%a -> %a" print_ty ty1 print_ty ty2
84 178
  | Ttuple tylist ->
......
89 183
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
90 184
  | Tstruct fieldlist ->
91 185
    fprintf fmt "struct {%a }"
92
      (Utils.fprintf_list ~sep:"; " print_struct_ty_field) fieldlist
186
      (Utils.fprintf_list ~sep:"; " (print_struct_ty_field pp_basic)) fieldlist
93 187
  | Tarray (e, ty) ->
94 188
    fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
95 189
  | Tlink ty ->
......
97 191
  | Tunivar ->
98 192
    fprintf fmt "'%s" (name_of_type ty.tid)
99 193

  
194
let print_ty = print_ty_param BasicT.pp
195
 
196
    
100 197
let rec print_node_struct_ty_field fmt (label, ty) =
101 198
  fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
102 199
and print_node_ty fmt ty =
103 200
  match ty.tdesc with
104 201
  | Tvar -> begin
105
(*Format.eprintf "DEBUG:Types.print_node@.";*)
202
    (*Format.eprintf "DEBUG:Types.print_node@.";*)
106 203
    fprintf fmt "_%s" (name_of_type ty.tid)
107
end
108
  | Tint ->
109
    fprintf fmt "int"
110
  | Treal ->
111
    fprintf fmt "real"
112
  | Tbool ->
113
    fprintf fmt "bool"
204
  end
205
  | Tbasic t -> BasicT.pp fmt t
114 206
  | Tclock t ->
115 207
    fprintf fmt "%a clock" print_node_ty t
116 208
  | Tstatic (_, t) ->
117 209
    fprintf fmt "%a" print_node_ty t
118 210
  | Tconst t ->
119 211
    fprintf fmt "%s" t
120
  | Trat ->
121
    fprintf fmt "rat"
122 212
  | Tarrow (ty1,ty2) ->
123 213
    fprintf fmt "%a -> %a" print_node_ty ty1 print_node_ty ty2
124 214
  | Ttuple tylist ->
......
201 291
  | Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
202 292
  | _          -> None
203 293

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

  
204 299
let rec is_scalar_type ty =
205 300
  match (repr ty).tdesc with
206 301
  | Tstatic (_, ty) -> is_scalar_type ty
207
  | Tbool
208
  | Tint
209
  | Treal -> true
302
  | Tbasic t -> BasicT.is_scalar_type t
210 303
  | _     -> false
211 304

  
212 305
let rec is_numeric_type ty =
213 306
 match (repr ty).tdesc with
214 307
 | Tstatic (_, ty) -> is_numeric_type ty
215
 | Tint
216
 | Treal -> true
308
 | Tbasic t -> BasicT.is_numeric_type t
217 309
 | _     -> false
218

  
310
    
219 311
let rec is_real_type ty =
220 312
 match (repr ty).tdesc with
221 313
 | Tstatic (_, ty) -> is_real_type ty
222
 | Treal -> true
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
223 321
 | _     -> false
224 322

  
225 323
let rec is_bool_type ty =
226 324
 match (repr ty).tdesc with
227 325
 | Tstatic (_, ty) -> is_bool_type ty
228
 | Tbool -> true
326
 | Tbasic t -> BasicT.is_bool_type t
229 327
 | _     -> false
230 328

  
231 329
let get_clock_base_type ty =
......
241 339

  
242 340
let rec is_dimension_type ty =
243 341
 match (repr ty).tdesc with
244
 | Tint
245
 | Tbool -> true
342
 | Tbasic t -> BasicT.is_dimension_type t
246 343
 | Tclock ty'
247 344
 | Tstatic (_, ty') -> is_dimension_type ty'
248 345
 | _                -> false
......
341 438
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)
342 439
let rec is_polymorphic ty =
343 440
  match ty.tdesc with
344
  | Tenum _ | Tvar | Tint | Treal | Tbool | Trat | Tconst _ -> false
441
  | Tenum _ | Tvar | Tbasic _ | Tconst _ -> false
345 442
  | Tclock ty -> is_polymorphic ty
346 443
  | Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2)
347 444
  | Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl
......
355 452
let mktyptuple nb typ =
356 453
  let array = Array.make nb typ in
357 454
  Ttuple (Array.to_list array)
455

  
456
let type_desc t = t.tdesc
457

  
458

  
459

  
460
let type_int = mk_basic BasicT.type_int_builder
461
let type_real = mk_basic BasicT.type_real_builder
462
let type_bool = mk_basic BasicT.type_bool_builder
463
let type_string = mk_basic BasicT.type_string_builder
358 464
    
465
end
466

  
467

  
468
module type S = 
469
sig
470
  module BasicT: BASIC_TYPES 
471
  type basic_type = BasicT.t
472
  type type_expr   =
473
    {mutable tdesc: type_desc;
474
     tid: int}
475
  and type_desc =
476
    | Tconst of ident (* type constant *)
477
    | Tbasic of basic_type
478
    | Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)
479
    | Tarrow of type_expr * type_expr
480
    | Ttuple of type_expr list
481
    | Tenum of ident list
482
    | Tstruct of (ident * type_expr) list
483
    | Tarray of dim_expr * type_expr
484
    | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
485
    | Tlink of type_expr (* During unification, make links instead of substitutions *)
486
    | Tvar (* Monomorphic type variable *)
487
    | Tunivar (* Polymorphic type variable *)
488

  
489
  type error =
490
      Unbound_value of ident  
491
    | Already_bound of ident
492
    | Already_defined of ident
493
    | Undefined_var of ISet.t
494
    | Declared_but_undefined of ident
495
    | Unbound_type of ident
496
    | Not_a_dimension
497
    | Not_a_constant
498
    | Assigned_constant of ident
499
    | WrongArity of int * int
500
    | WrongMorphism of int * int
501
    | Type_mismatch of ident
502
    | Type_clash of type_expr * type_expr
503
    | Poly_imported_node of ident
504

  
505
	  exception Unify of type_expr * type_expr
506
	  exception Error of Location.t * error
507

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

  
545
module type Sbasic = S with type BasicT.t = Basic.t 
546
  
547
module Main : Sbasic = Make (Basic)
548
include Main 
359 549

  
360 550

  
361 551
(* Local Variables: *)

Also available in: Unified diff