Project

General

Profile

Revision 12af4908 src/typing.ml

View differences:

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