Revision ca7ff3f7
Added by LĂ©lio Brun over 1 year ago
src/types.ml  

6  6 
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) 
7  7 
(* under the terms of the GNU Lesser General Public License *) 
8  8 
(* version 2.1. *) 
9 
(* *)


9 
(* *) 

10  10 
(* This file was originally from the Prelude compiler *) 
11 
(* *)


11 
(* *) 

12  12 
(********************************************************************) 
13  13  
14 
(** Types definitions and a few utility functions on types. *) 

15  14 
open Utils 
15 
(** Types definitions and a few utility functions on types. *) 

16  
16  17 
open Dimension 
17  18  
18 
module type BASIC_TYPES = 

19 
sig 

19 
module type BASIC_TYPES = sig 

20  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 

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 

35  49 
end 
36  50  
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 *) 

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

46  55  
47  56 
let type_string_builder = Tstring 
57  
48  58 
let type_int_builder = Tint 
59  
49  60 
let type_real_builder = Treal 
61  
50  62 
let type_bool_builder = Tbool 
51  63  
52  64 
open Format 
65  
53  66 
let pp fmt t = 
54  67 
match t with 
55  68 
 Tint > 
56 
fprintf fmt "int"


69 
fprintf fmt "int" 

57  70 
 Treal > 
58 
fprintf fmt "real"


71 
fprintf fmt "real" 

59  72 
 Tstring > 
60 
fprintf fmt "string"


73 
fprintf fmt "string" 

61  74 
 Tbool > 
62 
fprintf fmt "bool"


75 
fprintf fmt "bool" 

63  76 
 Trat > 
64 
fprintf fmt "rat"


77 
fprintf fmt "rat" 

65  78  
66  79 
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  80  
81 
let is_scalar_type t = 

82 
match t with Tbool  Tint  Treal > true  _ > false 

75  83  
76 
let is_numeric_type t = 

77 
match t with 

78 
 Tint 

79 
 Treal > true 

80 
 _ > false 

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

81  85  
82  86 
let is_int_type t = t = Tint 
87  
83  88 
let is_real_type t = t = Treal 
89  
84  90 
let is_bool_type t = t = Tbool 
85  91  
86 
let is_dimension_type t = 

87 
match t with 

88 
 Tint 

89 
 Tbool > true 

90 
 _ > false 

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

91  93  
92  94 
let is_unifiable b1 b2 = b1 == b2 
95  
93  96 
let unify _ _ = () 
94  97 
end 
95  98  
96  
97 


98 
module Make(BasicT : BASIC_TYPES) = 

99 
struct 

100  
99 
module Make (BasicT : BASIC_TYPES) = struct 

101  100 
module BasicT = BasicT 
101  
102  102 
type basic_type = BasicT.t 
103 
type type_expr = 

104 
{mutable tdesc: type_desc;


105 
tid: int} 

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


105  
106  106 
and type_desc = 
107 
 Tconst of ident (* type constant *) 

107 
 Tconst of ident 

108 
(* type constant *) 

108  109 
 Tbasic of basic_type 
109 
 Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *) 

110 
 Tclock of type_expr 

111 
(* A type expression explicitely tagged as carrying a clock *) 

110  112 
 Tarrow of type_expr * type_expr 
111  113 
 Ttuple of type_expr list 
112  114 
 Tenum of ident list 
113  115 
 Tstruct of (ident * type_expr) list 
114  116 
 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 *) 

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

119  125  
120  126 
(* {mutable tdesc: type_desc; *) 
121  127 
(* tid: int} *) 
...  ...  
123  129 
(* and type_desc = *) 
124  130 
(*  Tconst of ident (\* type constant *\) *) 
125  131 
(*  Tbasic of BasicT.t *) 
126 
(*  Tclock of type_expr (\* A type expression explicitely tagged as carrying a clock *\) *) 

132 
(*  Tclock of type_expr (\* A type expression explicitely tagged as carrying 

133 
a clock *\) *) 

127  134 
(*  Tarrow of type_expr * type_expr *) 
128  135 
(*  Ttuple of type_expr list *) 
129  136 
(*  Tenum of ident list *) 
130  137 
(*  Tstruct of (ident * type_expr) list *) 
131  138 
(*  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 *\) *) 

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

134  143 
(*  Tvar (\* Monomorphic type variable *\) *) 
135  144 
(*  Tunivar (\* Polymorphic type variable *\) *) 
136  145  
137  146 
type error = 
138 
Unbound_value of ident


147 
 Unbound_value of ident


139  148 
 Already_bound of ident 
140  149 
 Already_defined of ident 
141  150 
 Undefined_var of ISet.t 
...  ...  
150  159 
 Type_clash of type_expr * type_expr 
151  160 
 Poly_imported_node of ident 
152  161  
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 
(* Prettyprint*) 

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%s" print_ty t (if !Options.kind2_print then "" else " clock") 

172 
 Tstatic (_, t) > print_ty fmt 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%s" print_node_ty t (if !Options.kind2_print then "" else " clock") 

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 > 

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 
(* Prettyprint*) 

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 > 

226  242 
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) > 

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

258  275 
Utils.reset_names (); 
259 
fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2 

260 
 Poly_imported_node _ > 

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 is_static_type ty = 

295 
match (repr ty).tdesc with 

296 
 Tstatic _ > 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 


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 

471  519 
end 
472  520  
521 
module type S = sig 

522 
module BasicT : BASIC_TYPES 

473  523  
474 
module type S = 

475 
sig 

476 
module BasicT: BASIC_TYPES 

477  524 
type basic_type = BasicT.t 
478 
type type_expr = 

479 
{mutable tdesc: type_desc;


480 
tid: int} 

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


527  
481  528 
and type_desc = 
482 
 Tconst of ident (* type constant *) 

529 
 Tconst of ident 

530 
(* type constant *) 

483  531 
 Tbasic of basic_type 
484 
 Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *) 

532 
 Tclock of type_expr 

533 
(* A type expression explicitely tagged as carrying a clock *) 

485  534 
 Tarrow of type_expr * type_expr 
486  535 
 Ttuple of type_expr list 
487  536 
 Tenum of ident list 
488  537 
 Tstruct of (ident * type_expr) list 
489  538 
 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 *) 

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

494  547  
495  548 
type error = 
496 
Unbound_value of ident


549 
 Unbound_value of ident


497  550 
 Already_bound of ident 
498  551 
 Already_defined of ident 
499  552 
 Undefined_var of ISet.t 
...  ...  
508  561 
 Type_clash of type_expr * type_expr 
509  562 
 Poly_imported_node of ident 
510  563  
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 


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

556  645  
646 
include Main 

557  647  
558  648 
(* Local Variables: *) 
559  649 
(* compilecommand:"make C .." *) 
Also available in: Unified diff
reformatting