lustrec / src / types.ml @ 8b3afe43
History  View  Annotate  Download (7.82 KB)
1 
(*  

2 
* SchedMCore  A MultiCore Scheduling Framework 
3 
* Copyright (C) 20092011, ONERA, Toulouse, FRANCE  LIFL, Lille, FRANCE 
4 
* 
5 
* This file is part of Prelude 
6 
* 
7 
* Prelude is free software; you can redistribute it and/or 
8 
* modify it under the terms of the GNU Lesser General Public License 
9 
* as published by the Free Software Foundation ; either version 2 of 
10 
* the License, or (at your option) any later version. 
11 
* 
12 
* Prelude is distributed in the hope that it will be useful, but 
13 
* WITHOUT ANY WARRANTY ; without even the implied warranty of 
14 
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 
15 
* Lesser General Public License for more details. 
16 
* 
17 
* You should have received a copy of the GNU Lesser General Public 
18 
* License along with this program ; if not, write to the Free Software 
19 
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 021111307 
20 
* USA 
21 
* *) 
22  
23 
(** Types definitions and a few utility functions on types. *) 
24 
open Utils 
25 
open Dimension 
26  
27 
type type_expr = 
28 
{mutable tdesc: type_desc; 
29 
tid: int} 
30  
31 
and type_desc = 
32 
 Tconst of ident (* type constant *) 
33 
 Tint 
34 
 Treal 
35 
 Tbool 
36 
 Trat (* Actually unused for now. Only place where it can appear is 
37 
in a clock declaration *) 
38 
 Tclock of type_expr (* An type expression explicitely tagged as carrying a clock *) 
39 
 Tarrow of type_expr * type_expr 
40 
 Ttuple of type_expr list 
41 
 Tenum of ident list 
42 
 Tarray of dim_expr * type_expr 
43 
 Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *) 
44 
 Tlink of type_expr (* During unification, make links instead of substitutions *) 
45 
 Tvar (* Monomorphic type variable *) 
46 
 Tunivar (* Polymorphic type variable *) 
47  
48 
type error = 
49 
Unbound_value of ident 
50 
 Already_bound of ident 
51 
 Already_defined of ident 
52 
 Undefined_var of (unit IMap.t) 
53 
 Unbound_type of ident 
54 
 Not_a_dimension 
55 
 Not_a_constant 
56 
 WrongArity of int * int 
57 
 Type_clash of type_expr * type_expr 
58 
 Poly_imported_node of ident 
59  
60 
exception Unify of type_expr * type_expr 
61 
exception Error of Location.t * error 
62  
63 
(* Prettyprint*) 
64 
open Format 
65 

66 
let rec print_ty fmt ty = 
67 
match ty.tdesc with 
68 
 Tvar > 
69 
fprintf fmt "_%s" (name_of_type ty.tid) 
70 
 Tint > 
71 
fprintf fmt "int" 
72 
 Treal > 
73 
fprintf fmt "real" 
74 
 Tbool > 
75 
fprintf fmt "bool" 
76 
 Tclock t > 
77 
fprintf fmt "%a clock" print_ty t 
78 
 Tstatic (d, t) > 
79 
fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t 
80 
 Tconst t > 
81 
fprintf fmt "%s" t 
82 
 Trat > 
83 
fprintf fmt "rat" 
84 
 Tarrow (ty1,ty2) > 
85 
fprintf fmt "%a>%a" print_ty ty1 print_ty ty2 
86 
 Ttuple tylist > 
87 
fprintf fmt "(%a)" 
88 
(Utils.fprintf_list ~sep:"*" print_ty) tylist 
89 
 Tenum taglist > 
90 
fprintf fmt "(%a)" 
91 
(Utils.fprintf_list ~sep:" + " pp_print_string) taglist 
92 
 Tarray (e, ty) > 
93 
fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e 
94 
 Tlink ty > 
95 
print_ty fmt ty 
96 
 Tunivar > 
97 
fprintf fmt "'%s" (name_of_type ty.tid) 
98  
99 
let rec print_node_ty fmt ty = 
100 
match ty.tdesc with 
101 
 Tint > 
102 
fprintf fmt "int" 
103 
 Treal > 
104 
fprintf fmt "real" 
105 
 Tbool > 
106 
fprintf fmt "bool" 
107 
 Tclock t > 
108 
fprintf fmt "%a clock" print_ty t 
109 
 Tstatic (_, t) > 
110 
fprintf fmt "%a" print_node_ty t 
111 
 Tconst t > 
112 
fprintf fmt "%s" t 
113 
 Trat > 
114 
fprintf fmt "rat" 
115 
 Tarrow (ty1,ty2) > 
116 
fprintf fmt "%a>%a" print_ty ty1 print_ty ty2 
117 
 Ttuple tylist > 
118 
fprintf fmt "(%a)" 
119 
(Utils.fprintf_list ~sep:"*" print_ty) tylist 
120 
 Tenum taglist > 
121 
fprintf fmt "(%a)" 
122 
(Utils.fprintf_list ~sep:" + " pp_print_string) taglist 
123 
 Tarray (e, ty) > 
124 
fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e 
125 
 Tlink ty > 
126 
print_ty fmt ty 
127 
 Tunivar > 
128 
fprintf fmt "'%s" (name_of_type ty.tid) 
129 
 _ > assert false 
130  
131 
let pp_error fmt = function 
132 
 Unbound_value id > 
133 
fprintf fmt "Unknown value %s@." id 
134 
 Unbound_type id > 
135 
fprintf fmt "Unknown type %s@." id 
136 
 Already_bound id > 
137 
fprintf fmt "%s is already declared@." id 
138 
 Already_defined id > 
139 
fprintf fmt "Multiple definitions of variable %s@." id 
140 
 Not_a_constant > 
141 
fprintf fmt "This expression is not a constant@." 
142 
 Not_a_dimension > 
143 
fprintf fmt "This expression is not a valid dimension@." 
144 
 WrongArity (ar1, ar2) > 
145 
fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2 
146 
 Undefined_var vmap > 
147 
fprintf fmt "No definition provided for variable(s): %a@." 
148 
(Utils.fprintf_list ~sep:"," pp_print_string) 
149 
(fst (Utils.list_of_imap vmap)) 
150 
 Type_clash (ty1,ty2) > 
151 
Utils.reset_names (); 
152 
fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2 
153 
 Poly_imported_node id > 
154 
fprintf fmt "Imported nodes cannot have a polymorphic type@." 
155  
156  
157 
let new_id = ref (1) 
158  
159 
let new_ty desc = 
160 
incr new_id; {tdesc = desc; tid = !new_id } 
161  
162 
let new_var () = 
163 
new_ty Tvar 
164  
165 
let new_univar () = 
166 
new_ty Tunivar 
167  
168 
let rec repr = 
169 
function 
170 
{tdesc = Tlink t'} > 
171 
repr t' 
172 
 t > t 
173  
174 
let get_static_value ty = 
175 
match (repr ty).tdesc with 
176 
 Tstatic (d, _) > Some d 
177 
 _ > None 
178  
179 
let rec is_dimension_type ty = 
180 
match (repr ty).tdesc with 
181 
 Tint 
182 
 Tbool > true 
183 
 Tclock ty' 
184 
 Tstatic (_, ty') > is_dimension_type ty' 
185 
 _ > false 
186  
187 
let rec dynamic_type ty = 
188 
let ty = repr ty in 
189 
match ty.tdesc with 
190 
 Tstatic (_, ty') > ty' 
191 
 _ > ty 
192  
193 
let map_tuple_type f ty = 
194 
let ty = dynamic_type ty in 
195 
match ty.tdesc with 
196 
 (Ttuple ty_list) > { ty with tdesc = Ttuple (List.map f ty_list) } 
197 
 _ > f ty 
198 
let rec is_array_type ty = 
199 
match (repr ty).tdesc with 
200 
 Tarray _ > true 
201 
 Tstatic (_, ty') > is_array_type ty' 
202 
 _ > false 
203  
204 
let array_type_dimension ty = 
205 
match (dynamic_type ty).tdesc with 
206 
 Tarray (d, _) > d 
207 
 _ > assert false 
208  
209 
let rec array_type_multi_dimension ty = 
210 
match (dynamic_type ty).tdesc with 
211 
 Tarray (d, ty') > d :: array_type_multi_dimension ty' 
212 
 _ > [] 
213  
214 
let array_element_type ty = 
215 
match (dynamic_type ty).tdesc with 
216 
 Tarray (_, ty') > ty' 
217 
 _ > assert false 
218  
219 
let rec array_base_type ty = 
220 
let ty = repr ty in 
221 
match ty.tdesc with 
222 
 Tarray (_, ty') 
223 
 Tstatic (_, ty') > array_base_type ty' 
224 
 _ > ty 
225  
226 
let rec is_generic_type ty = 
227 
match (dynamic_type ty).tdesc with 
228 
 Tarray (d, ty') > 
229 
(not (Dimension.is_dimension_const d))  (is_generic_type ty') 
230 
 _ > false 
231  
232 
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type 
233 
(ensured by language syntax) *) 
234 
let rec split_arrow ty = 
235 
match (repr ty).tdesc with 
236 
 Tarrow (tin,tout) > tin,tout 
237 
 Tstatic (_, ty') > split_arrow ty' 
238 
(* Functions are not first order, I don't think the var case 
239 
needs to be considered here *) 
240 
 _ > Format.eprintf "%a@." print_ty ty; assert false 
241  
242 
(** Returns the type corresponding to a type list. *) 
243 
let type_of_type_list tyl = 
244 
if (List.length tyl) > 1 then 
245 
new_ty (Ttuple tyl) 
246 
else 
247 
List.hd tyl 
248  
249 
let type_list_of_type ty = 
250 
match (repr ty).tdesc with 
251 
 Ttuple tl > tl 
252 
 _ > [ty] 
253  
254 
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *) 
255 
let rec is_polymorphic ty = 
256 
match ty.tdesc with 
257 
 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false 
258 
 Tclock ty > is_polymorphic ty 
259 
 Tarrow (ty1,ty2) > (is_polymorphic ty1)  (is_polymorphic ty2) 
260 
 Ttuple tl > List.exists (fun t > is_polymorphic t) tl 
261 
 Tlink t' > is_polymorphic t' 
262 
 Tarray (d, ty) 
263 
 Tstatic (d, ty) > Dimension.is_polymorphic d  is_polymorphic ty 
264 
 Tunivar > true 
265  
266  
267 
let mktyptuple nb typ = 
268 
let array = Array.make nb typ in 
269 
Ttuple (Array.to_list array) 
270  
271  
272 
(* Local Variables: *) 
273 
(* compilecommand:"make C .." *) 
274 
(* End: *) 