lustrec / src / types.ml @ 0cbf0839
History  View  Annotate  Download (7.01 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 pp_error fmt = function 
100 
 Unbound_value id > 
101 
fprintf fmt "Unknown value %s@." id 
102 
 Unbound_type id > 
103 
fprintf fmt "Unknown type %s@." id 
104 
 Already_bound id > 
105 
fprintf fmt "%s is already declared@." id 
106 
 Already_defined id > 
107 
fprintf fmt "Multiple definitions of variable %s@." id 
108 
 Not_a_constant > 
109 
fprintf fmt "This expression is not a constant@." 
110 
 Not_a_dimension > 
111 
fprintf fmt "This expression is not a valid dimension@." 
112 
 WrongArity (ar1, ar2) > 
113 
fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2 
114 
 Undefined_var vmap > 
115 
fprintf fmt "No definition provided for variable(s): %a@." 
116 
(Utils.fprintf_list ~sep:"," pp_print_string) 
117 
(fst (Utils.list_of_imap vmap)) 
118 
 Type_clash (ty1,ty2) > 
119 
Utils.reset_names (); 
120 
fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2 
121 
 Poly_imported_node id > 
122 
fprintf fmt "Imported nodes cannot have a polymorphic type@." 
123  
124  
125 
let new_id = ref (1) 
126  
127 
let new_ty desc = 
128 
incr new_id; {tdesc = desc; tid = !new_id } 
129  
130 
let new_var () = 
131 
new_ty Tvar 
132  
133 
let new_univar () = 
134 
new_ty Tunivar 
135  
136 
let rec repr = 
137 
function 
138 
{tdesc = Tlink t'} > 
139 
repr t' 
140 
 t > t 
141  
142 
let get_static_value ty = 
143 
match (repr ty).tdesc with 
144 
 Tstatic (d, _) > Some d 
145 
 _ > None 
146  
147 
let rec is_dimension_type ty = 
148 
match (repr ty).tdesc with 
149 
 Tint 
150 
 Tbool > true 
151 
 Tclock ty' 
152 
 Tstatic (_, ty') > is_dimension_type ty' 
153 
 _ > false 
154  
155 
let rec dynamic_type ty = 
156 
let ty = repr ty in 
157 
match ty.tdesc with 
158 
 Tstatic (_, ty') > ty' 
159 
 _ > ty 
160  
161 
let map_tuple_type f ty = 
162 
let ty = dynamic_type ty in 
163 
match ty.tdesc with 
164 
 (Ttuple ty_list) > { ty with tdesc = Ttuple (List.map f ty_list) } 
165 
 _ > f ty 
166 
let rec is_array_type ty = 
167 
match (repr ty).tdesc with 
168 
 Tarray _ > true 
169 
 Tstatic (_, ty') > is_array_type ty' 
170 
 _ > false 
171  
172 
let array_type_dimension ty = 
173 
match (dynamic_type ty).tdesc with 
174 
 Tarray (d, _) > d 
175 
 _ > assert false 
176  
177 
let rec array_type_multi_dimension ty = 
178 
match (dynamic_type ty).tdesc with 
179 
 Tarray (d, ty') > d :: array_type_multi_dimension ty' 
180 
 _ > [] 
181  
182 
let array_element_type ty = 
183 
match (dynamic_type ty).tdesc with 
184 
 Tarray (_, ty') > ty' 
185 
 _ > assert false 
186  
187 
let rec array_base_type ty = 
188 
let ty = repr ty in 
189 
match ty.tdesc with 
190 
 Tarray (_, ty') 
191 
 Tstatic (_, ty') > array_base_type ty' 
192 
 _ > ty 
193  
194 
let rec is_generic_type ty = 
195 
match (dynamic_type ty).tdesc with 
196 
 Tarray (d, ty') > 
197 
(not (Dimension.is_dimension_const d))  (is_generic_type ty') 
198 
 _ > false 
199  
200 
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type 
201 
(ensured by language syntax) *) 
202 
let rec split_arrow ty = 
203 
match (repr ty).tdesc with 
204 
 Tarrow (tin,tout) > tin,tout 
205 
 Tstatic (_, ty') > split_arrow ty' 
206 
(* Functions are not first order, I don't think the var case 
207 
needs to be considered here *) 
208 
 _ > Format.eprintf "%a@." print_ty ty; assert false 
209  
210 
(** Returns the type corresponding to a type list. *) 
211 
let type_of_type_list tyl = 
212 
if (List.length tyl) > 1 then 
213 
new_ty (Ttuple tyl) 
214 
else 
215 
List.hd tyl 
216  
217 
let type_list_of_type ty = 
218 
match (repr ty).tdesc with 
219 
 Ttuple tl > tl 
220 
 _ > [ty] 
221  
222 
(** [is_polymorphic ty] returns true if [ty] is polymorphic. *) 
223 
let rec is_polymorphic ty = 
224 
match ty.tdesc with 
225 
 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false 
226 
 Tclock ty > is_polymorphic ty 
227 
 Tarrow (ty1,ty2) > (is_polymorphic ty1)  (is_polymorphic ty2) 
228 
 Ttuple tl > List.exists (fun t > is_polymorphic t) tl 
229 
 Tlink t' > is_polymorphic t' 
230 
 Tarray (d, ty) 
231 
 Tstatic (d, ty) > Dimension.is_polymorphic d  is_polymorphic ty 
232 
 Tunivar > true 
233  
234  
235 
let mktyptuple nb typ = 
236 
let array = Array.make nb typ in 
237 
Ttuple (Array.to_list array) 
238  
239  
240 
(* Local Variables: *) 
241 
(* compilecommand:"make C .." *) 
242 
(* End: *) 