Revision 12af4908 src/typing.ml
src/typing.ml  

48  48 
 Tarrow (t1, t2) > 
49  49 
(occurs tvar t1)  (occurs tvar t2) 
50  50 
 Ttuple tl > 
51 
List.exists (occurs tvar) tl 

51 
List.exists (occurs tvar) tl 

52 
 Tstruct fl > 

53 
List.exists (fun (f, t) > occurs tvar t) fl 

52  54 
 Tarray (_, t) 
53  55 
 Tstatic (_, t) 
54  56 
 Tclock t 
...  ...  
64  66 
ty.tdesc < Tunivar 
65  67 
 Tarrow (t1,t2) > 
66  68 
generalize t1; generalize t2 
67 
 Ttuple tlist > 

68 
List.iter generalize tlist 

69 
 Ttuple tl > 

70 
List.iter generalize tl 

71 
 Tstruct fl > 

72 
List.iter (fun (f, t) > generalize t) fl 

69  73 
 Tstatic (d, t) 
70  74 
 Tarray (d, t) > Dimension.generalize d; generalize t 
71  75 
 Tclock t 
...  ...  
83  87 
Tarrow ((instantiate inst_vars inst_dim_vars t1), (instantiate inst_vars inst_dim_vars t2))} 
84  88 
 Ttuple tlist > 
85  89 
{ty with tdesc = Ttuple (List.map (instantiate inst_vars inst_dim_vars) tlist)} 
90 
 Tstruct flist > 

91 
{ty with tdesc = Tstruct (List.map (fun (f, t) > (f, instantiate inst_vars inst_dim_vars t)) flist)} 

86  92 
 Tclock t > 
87  93 
{ty with tdesc = Tclock (instantiate inst_vars inst_dim_vars t)} 
88  94 
 Tstatic (d, t) > 
...  ...  
111  117 
 Tydec_clock ty > Type_predef.type_clock (type_coretype type_dim ty) 
112  118 
 Tydec_const c > Type_predef.type_const c 
113  119 
 Tydec_enum tl > Type_predef.type_enum tl 
114 
 Tydec_struct fl > assert false (*Type_predef.type_struct fl*)


120 
 Tydec_struct fl > Type_predef.type_struct (List.map (fun (f, ty) > (f, type_coretype type_dim ty)) fl)


115  121 
 Tydec_array (d, ty) > 
116  122 
begin 
117  123 
type_dim d; 
...  ...  
128  134 
 Tconst c > Tydec_const c 
129  135 
 Tclock t > Tydec_clock (coretype_type t) 
130  136 
 Tenum tl > Tydec_enum tl 
137 
 Tstruct fl > Tydec_struct (List.map (fun (f, t) > (f, coretype_type t)) fl) 

131  138 
 Tarray (d, t) > Tydec_array (d, coretype_type t) 
132  139 
 Tstatic (_, t) > coretype_type t 
133  140 
 _ > assert false 
...  ...  
163  170 
unify t1 t1'; 
164  171 
unify t2 t2' 
165  172 
end 
166 
 Ttuple tlist1, Ttuple tlist2 > 

167 
if (List.length tlist1) <> (List.length tlist2) then 

168 
raise (Unify (t1, t2)) 

169 
else 

170 
List.iter2 unify tlist1 tlist2 

173 
 Ttuple tl, Ttuple tl' when List.length tl = List.length tl' > 

174 
List.iter2 unify tl tl' 

175 
 Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' > 

176 
List.iter2 (fun (_, t) (_, t') > unify t t') fl fl' 

171  177 
 Tclock _, Tstatic _ 
172  178 
 Tstatic _, Tclock _ > raise (Unify (t1, t2)) 
173  179 
 Tclock t1', _ > unify t1' t2 
...  ...  
216  222 
semi_unify t1 t1'; 
217  223 
semi_unify t2 t2' 
218  224 
end 
219 
 Ttuple tlist1, Ttuple tlist2 > 

220 
if (List.length tlist1) <> (List.length tlist2) then 

221 
raise (Unify (t1, t2)) 

222 
else 

223 
List.iter2 semi_unify tlist1 tlist2 

225 
 Ttuple tl, Ttuple tl' when List.length tl = List.length tl' > 

226 
List.iter2 semi_unify tl tl' 

227 
 Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' > 

228 
List.iter2 (fun (_, t) (_, t') > semi_unify t t') fl fl' 

224  229 
 Tclock _, Tstatic _ 
225  230 
 Tstatic _, Tclock _ > raise (Unify (t1, t2)) 
226  231 
 Tclock t1', _ > semi_unify t1' t2 
...  ...  
234  239 
let def_t = get_type_definition t in 
235  240 
semi_unify t1 def_t 
236  241 
 Tenum tl, Tenum tl' when tl == tl' > () 
242  
237  243 
 Tstatic (e1, t1'), Tstatic (e2, t2') 
238  244 
 Tarray (e1, t1'), Tarray (e2, t2') > 
239  245 
begin 
...  ...  
244  250 
end 
245  251 
 _,_ > raise (Unify (t1, t2)) 
246  252  
253 
(* Expected type ty1, got type ty2 *) 

247  254 
let try_unify ty1 ty2 loc = 
248  255 
try 
249  256 
unify ty1 ty2 
...  ...  
262  269 
 Dimension.Unify _ > 
263  270 
raise (Error (loc, Type_clash (ty1,ty2))) 
264  271  
272 
(* ty1 is a subtype of ty2 *) 

273 
let rec sub_unify sub ty1 ty2 = 

274 
match (repr ty1).tdesc, (repr ty2).tdesc with 

275 
 Ttuple [t1] , Ttuple [t2] > sub_unify sub t1 t2 

276 
 Ttuple tl1 , Ttuple tl2 > 

277 
if List.length tl1 <> List.length tl2 

278 
then raise (Unify (ty1, ty2)) 

279 
else List.iter2 (sub_unify sub) tl1 tl2 

280 
 Ttuple [t1] , _ > sub_unify sub t1 ty2 

281 
 _ , Ttuple [t2] > sub_unify sub ty1 t2 

282 
 Tstruct tl1 , Tstruct tl2 > 

283 
if List.map fst tl1 <> List.map fst tl2 

284 
then raise (Unify (ty1, ty2)) 

285 
else List.iter2 (fun (_, t1) (_, t2) > sub_unify sub t1 t2) tl1 tl2 

286 
 Tstatic (d1, t1) , Tstatic (d2, t2) > 

287 
begin 

288 
sub_unify sub t1 t2; 

289 
Dimension.eval Basic_library.eval_env (fun c > None) d1; 

290 
Dimension.eval Basic_library.eval_env (fun c > None) d2; 

291 
Dimension.unify d1 d2 

292 
end 

293 
 Tstatic (r_d, t1) , _ when sub > sub_unify sub ty2 t1 

294 
 _ > unify ty2 ty1 

295  
296 
let try_sub_unify sub ty1 ty2 loc = 

297 
try 

298 
sub_unify sub ty1 ty2 

299 
with 

300 
 Unify _ > 

301 
raise (Error (loc, Type_clash (ty1,ty2))) 

302 
 Dimension.Unify _ > 

303 
raise (Error (loc, Type_clash (ty1,ty2))) 

304  
305 
let type_struct_field loc ftyp (label, f) = 

306 
if Hashtbl.mem field_table label 

307 
then let tydec = Hashtbl.find field_table label in 

308 
let tydec_struct = get_struct_type_fields tydec in 

309 
let ty_label = type_coretype (fun d > ()) (List.assoc label tydec_struct) in 

310 
begin 

311 
try_unify ty_label (ftyp loc f) loc; 

312 
type_coretype (fun d > ()) tydec 

313 
end 

314 
else raise (Error (loc, Unbound_value ("struct field " ^ label))) 

315  
265  316 
let rec type_const loc c = 
266  317 
match c with 
267 
 Const_int _ > Type_predef.type_int 

268 
 Const_real _ > Type_predef.type_real 

269 
 Const_float _ > Type_predef.type_real 

270 
 Const_array ca > let d = Dimension.mkdim_int loc (List.length ca) in 

318 
 Const_int _ > Type_predef.type_int


319 
 Const_real _ > Type_predef.type_real


320 
 Const_float _ > Type_predef.type_real


321 
 Const_array ca > let d = Dimension.mkdim_int loc (List.length ca) in


271  322 
let ty = new_var () in 
272 
List.iter (fun e > try_unify (type_const loc e) ty loc) ca;


323 
List.iter (fun e > try_unify ty (type_const loc e) loc) ca;


273  324 
Type_predef.type_array d ty 
274 
 Const_tag t > 

325 
 Const_tag t >


275  326 
if Hashtbl.mem tag_table t 
276  327 
then type_coretype (fun d > ()) (Hashtbl.find tag_table t) 
277  328 
else raise (Error (loc, Unbound_value ("enum tag " ^ t))) 
329 
 Const_struct fl > 

330 
let ty_struct = new_var () in 

331 
begin 

332 
List.iter (fun f > try_unify ty_struct (type_struct_field loc type_const f) loc) fl; 

333 
ty_struct 

334 
end 

278  335  
279  336 
(* The following typing functions take as parameter an environment [env] 
280  337 
and whether the element being typed is expected to be constant [const]. 
...  ...  
317  374 
real_static_type 
318  375 
else real_type in 
319  376 
(*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*) 
377 
try_sub_unify sub real_type formal_type loc 

378 
(* 

379 
and type_subtyping_tuple loc real_type formal_type = 

320  380 
let real_types = type_list_of_type real_type in 
321  381 
let formal_types = type_list_of_type formal_type in 
322  382 
if (List.length real_types) <> (List.length formal_types) 
...  ...  
328  388 
 Tstatic _ , Tstatic _ when sub > try_unify formal_type real_type loc 
329  389 
 Tstatic (r_d, r_ty), _ when sub > try_unify formal_type r_ty loc 
330  390 
 _ > try_unify formal_type real_type loc 
331  
391 
*) 

332  392 
and type_ident env in_main loc const id = 
333  393 
type_expr env in_main const (expr_of_ident id loc) 
334  394 
Also available in: Unified diff