Revision 66359a5e src/types.ml
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 
(* Prettyprint*) 
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