Revision 66359a5e
Added by Pierre-Loïc Garoche about 7 years ago
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
[general] large modification: added machine types, a second typing phase dealing with machine types (eg uint8)
typing was transformed as a functor and parametrized by basic types (int/real/bool)
it can also be applied multiple times on the same program