lustrec / src / typing.ml @ 1eda3e78
History  View  Annotate  Download (29.2 KB)
1 
(********************************************************************) 

2 
(* *) 
3 
(* The LustreC compiler toolset / The LustreC Development Team *) 
4 
(* Copyright 2012   ONERA  CNRS  INPT  LIFL *) 
5 
(* *) 
6 
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) 
7 
(* under the terms of the GNU Lesser General Public License *) 
8 
(* version 2.1. *) 
9 
(* *) 
10 
(* This file was originally from the Prelude compiler *) 
11 
(* *) 
12 
(********************************************************************) 
13  
14 
(** Main typing module. Classic inference algorithm with destructive 
15 
unification. *) 
16  
17 
let debug fmt args = () (* Format.eprintf "%a" *) 
18 
(* Though it shares similarities with the clock calculus module, no code 
19 
is shared. Simple environments, very limited identifier scoping, no 
20 
identifier redefinition allowed. *) 
21  
22 
open Utils 
23 
(* Yes, opening both modules is dirty as some type names will be 
24 
overwritten, yet this makes notations far lighter.*) 
25 
open LustreSpec 
26 
open Corelang 
27 
open Types 
28 
open Format 
29  
30 
let pp_typing_env fmt env = 
31 
Env.pp_env print_ty fmt env 
32  
33 
(** [occurs tvar ty] returns true if the type variable [tvar] occurs in 
34 
type [ty]. False otherwise. *) 
35 
let rec occurs tvar ty = 
36 
let ty = repr ty in 
37 
match ty.tdesc with 
38 
 Tvar > ty=tvar 
39 
 Tarrow (t1, t2) > 
40 
(occurs tvar t1)  (occurs tvar t2) 
41 
 Ttuple tl > 
42 
List.exists (occurs tvar) tl 
43 
 Tstruct fl > 
44 
List.exists (fun (f, t) > occurs tvar t) fl 
45 
 Tarray (_, t) 
46 
 Tstatic (_, t) 
47 
 Tclock t 
48 
 Tlink t > occurs tvar t 
49 
 Tenum _  Tconst _  Tunivar  Tint  Treal  Tbool  Trat > false 
50  
51 
(** Promote monomorphic type variables to polymorphic type variables. *) 
52 
(* Generalize by sideeffects *) 
53 
let rec generalize ty = 
54 
match ty.tdesc with 
55 
 Tvar > 
56 
(* No scopes, always generalize *) 
57 
ty.tdesc < Tunivar 
58 
 Tarrow (t1,t2) > 
59 
generalize t1; generalize t2 
60 
 Ttuple tl > 
61 
List.iter generalize tl 
62 
 Tstruct fl > 
63 
List.iter (fun (f, t) > generalize t) fl 
64 
 Tstatic (d, t) 
65 
 Tarray (d, t) > Dimension.generalize d; generalize t 
66 
 Tclock t 
67 
 Tlink t > 
68 
generalize t 
69 
 Tenum _  Tconst _  Tunivar  Tint  Treal  Tbool  Trat > () 
70  
71 
(** Downgrade polymorphic type variables to monomorphic type variables *) 
72 
let rec instantiate inst_vars inst_dim_vars ty = 
73 
let ty = repr ty in 
74 
match ty.tdesc with 
75 
 Tenum _  Tconst _  Tvar  Tint  Treal  Tbool  Trat > ty 
76 
 Tarrow (t1,t2) > 
77 
{ty with tdesc = 
78 
Tarrow ((instantiate inst_vars inst_dim_vars t1), (instantiate inst_vars inst_dim_vars t2))} 
79 
 Ttuple tlist > 
80 
{ty with tdesc = Ttuple (List.map (instantiate inst_vars inst_dim_vars) tlist)} 
81 
 Tstruct flist > 
82 
{ty with tdesc = Tstruct (List.map (fun (f, t) > (f, instantiate inst_vars inst_dim_vars t)) flist)} 
83 
 Tclock t > 
84 
{ty with tdesc = Tclock (instantiate inst_vars inst_dim_vars t)} 
85 
 Tstatic (d, t) > 
86 
{ty with tdesc = Tstatic (Dimension.instantiate inst_dim_vars d, instantiate inst_vars inst_dim_vars t)} 
87 
 Tarray (d, t) > 
88 
{ty with tdesc = Tarray (Dimension.instantiate inst_dim_vars d, instantiate inst_vars inst_dim_vars t)} 
89 
 Tlink t > 
90 
(* should not happen *) 
91 
{ty with tdesc = Tlink (instantiate inst_vars inst_dim_vars t)} 
92 
 Tunivar > 
93 
try 
94 
List.assoc ty.tid !inst_vars 
95 
with Not_found > 
96 
let var = new_var () in 
97 
inst_vars := (ty.tid, var)::!inst_vars; 
98 
var 
99  
100 
(* [type_coretype cty] types the type declaration [cty] *) 
101 
let rec type_coretype type_dim cty = 
102 
match (*get_repr_type*) cty with 
103 
 Tydec_any > new_var () 
104 
 Tydec_int > Type_predef.type_int 
105 
 Tydec_real > Type_predef.type_real 
106 
 Tydec_float > Type_predef.type_real 
107 
 Tydec_bool > Type_predef.type_bool 
108 
 Tydec_clock ty > Type_predef.type_clock (type_coretype type_dim ty) 
109 
 Tydec_const c > Type_predef.type_const c 
110 
 Tydec_enum tl > Type_predef.type_enum tl 
111 
 Tydec_struct fl > Type_predef.type_struct (List.map (fun (f, ty) > (f, type_coretype type_dim ty)) fl) 
112 
 Tydec_array (d, ty) > 
113 
begin 
114 
type_dim d; 
115 
Type_predef.type_array d (type_coretype type_dim ty) 
116 
end 
117  
118 
(* [coretype_type] is the reciprocal of [type_typecore] *) 
119 
let rec coretype_type ty = 
120 
match (repr ty).tdesc with 
121 
 Tvar > Tydec_any 
122 
 Tint > Tydec_int 
123 
 Treal > Tydec_real 
124 
 Tbool > Tydec_bool 
125 
 Tconst c > Tydec_const c 
126 
 Tclock t > Tydec_clock (coretype_type t) 
127 
 Tenum tl > Tydec_enum tl 
128 
 Tstruct fl > Tydec_struct (List.map (fun (f, t) > (f, coretype_type t)) fl) 
129 
 Tarray (d, t) > Tydec_array (d, coretype_type t) 
130 
 Tstatic (_, t) > coretype_type t 
131 
 _ > assert false 
132  
133 
let get_coretype_definition tname = 
134 
try 
135 
let top = Hashtbl.find type_table (Tydec_const tname) in 
136 
match top.top_decl_desc with 
137 
 TypeDef tdef > tdef.tydef_desc 
138 
 _ > assert false 
139 
with Not_found > raise (Error (Location.dummy_loc, Unbound_type tname)) 
140  
141 
let get_type_definition tname = 
142 
type_coretype (fun d > ()) (get_coretype_definition tname) 
143  
144 
(* Equality on ground types only *) 
145 
(* Should be used between local variables which must have a ground type *) 
146 
let rec eq_ground t1 t2 = 
147 
let t1 = repr t1 in 
148 
let t2 = repr t2 in 
149 
t1==t2  
150 
match t1.tdesc, t2.tdesc with 
151 
 Tint, Tint  Tbool, Tbool  Trat, Trat  Treal, Treal > true 
152 
 Tenum tl, Tenum tl' when tl == tl' > true 
153 
 Ttuple tl, Ttuple tl' when List.length tl = List.length tl' > List.for_all2 eq_ground tl tl' 
154 
 Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' > List.for_all2 (fun (_, t) (_, t') > eq_ground t t') fl fl' 
155 
 (Tconst t, _) > 
156 
let def_t = get_type_definition t in 
157 
eq_ground def_t t2 
158 
 (_, Tconst t) > 
159 
let def_t = get_type_definition t in 
160 
eq_ground t1 def_t 
161 
 Tarrow (t1,t2), Tarrow (t1',t2') > eq_ground t1 t1' && eq_ground t2 t2' 
162 
 Tclock t1', Tclock t2' > eq_ground t1' t2' 
163 
 Tstatic (e1, t1'), Tstatic (e2, t2') 
164 
 Tarray (e1, t1'), Tarray (e2, t2') > Dimension.is_eq_dimension e1 e2 && eq_ground t1' t2' 
165 
 _ > false 
166  
167 
(** [unify t1 t2] unifies types [t1] and [t2] 
168 
using standard destructive unification. 
169 
Raises [Unify (t1,t2)] if the types are not unifiable. 
170 
[t1] is a expected/formal/spec type, [t2] is a computed/real/implem type, 
171 
so in case of unification error: expected type [t1], got type [t2]. 
172 
If [sub]typing is allowed, [t2] may be a subtype of [t1]. 
173 
If [semi] unification is required, 
174 
[t1] should furthermore be an instance of [t2] 
175 
and constants are handled differently.*) 
176 
let unify ?(sub=false) ?(semi=false) t1 t2 = 
177 
let rec unif t1 t2 = 
178 
let t1 = repr t1 in 
179 
let t2 = repr t2 in 
180 
if t1==t2 then 
181 
() 
182 
else 
183 
match t1.tdesc,t2.tdesc with 
184 
(* strictly subtyping cases first *) 
185 
 _ , Tclock t2 when sub && (get_clock_base_type t1 = None) > 
186 
unif t1 t2 
187 
 _ , Tstatic (d2, t2) when sub && (get_static_value t1 = None) > 
188 
unif t1 t2 
189 
(* This case is not mandatory but will keep "older" types *) 
190 
 Tvar, Tvar > 
191 
if t1.tid < t2.tid then 
192 
t2.tdesc < Tlink t1 
193 
else 
194 
t1.tdesc < Tlink t2 
195 
 Tvar, _ when (not semi) && (not (occurs t1 t2)) > 
196 
t1.tdesc < Tlink t2 
197 
 _, Tvar when (not (occurs t2 t1)) > 
198 
t2.tdesc < Tlink t1 
199 
 Tarrow (t1,t2), Tarrow (t1',t2') > 
200 
begin 
201 
unif t2 t2'; 
202 
unif t1' t1 
203 
end 
204 
 Ttuple tl, Ttuple tl' when List.length tl = List.length tl' > 
205 
List.iter2 unif tl tl' 
206 
 Ttuple [t1] , _ > unif t1 t2 
207 
 _ , Ttuple [t2] > unif t1 t2 
208 
 Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' > 
209 
List.iter2 (fun (_, t) (_, t') > unif t t') fl fl' 
210 
 Tclock _, Tstatic _ 
211 
 Tstatic _, Tclock _ > raise (Unify (t1, t2)) 
212 
 Tclock t1', Tclock t2' > unif t1' t2' 
213 
 Tint, Tint  Tbool, Tbool  Trat, Trat  Treal, Treal 
214 
 Tunivar, _  _, Tunivar > () 
215 
 (Tconst t, _) > 
216 
let def_t = get_type_definition t in 
217 
unif def_t t2 
218 
 (_, Tconst t) > 
219 
let def_t = get_type_definition t in 
220 
unif t1 def_t 
221 
 Tenum tl, Tenum tl' when tl == tl' > () 
222 
 Tstatic (e1, t1'), Tstatic (e2, t2') 
223 
 Tarray (e1, t1'), Tarray (e2, t2') > 
224 
let eval_const = 
225 
if semi 
226 
then (fun c > Some (Dimension.mkdim_ident Location.dummy_loc c)) 
227 
else (fun c > None) in 
228 
begin 
229 
unif t1' t2'; 
230 
Dimension.eval Basic_library.eval_env eval_const e1; 
231 
Dimension.eval Basic_library.eval_env eval_const e2; 
232 
Dimension.unify ~semi:semi e1 e2; 
233 
end 
234 
 _,_ > raise (Unify (t1, t2)) 
235 
in unif t1 t2 
236  
237 
(* Expected type ty1, got type ty2 *) 
238 
let try_unify ?(sub=false) ?(semi=false) ty1 ty2 loc = 
239 
try 
240 
unify ~sub:sub ~semi:semi ty1 ty2 
241 
with 
242 
 Unify _ > 
243 
raise (Error (loc, Type_clash (ty1,ty2))) 
244 
 Dimension.Unify _ > 
245 
raise (Error (loc, Type_clash (ty1,ty2))) 
246  
247 
let rec type_struct_const_field loc (label, c) = 
248 
if Hashtbl.mem field_table label 
249 
then let tydef = Hashtbl.find field_table label in 
250 
let tydec = (typedef_of_top tydef).tydef_desc in 
251 
let tydec_struct = get_struct_type_fields tydec in 
252 
let ty_label = type_coretype (fun d > ()) (List.assoc label tydec_struct) in 
253 
begin 
254 
try_unify ty_label (type_const loc c) loc; 
255 
type_coretype (fun d > ()) tydec 
256 
end 
257 
else raise (Error (loc, Unbound_value ("struct field " ^ label))) 
258  
259 
and type_const loc c = 
260 
match c with 
261 
 Const_int _ > Type_predef.type_int 
262 
 Const_real _ > Type_predef.type_real 
263 
 Const_float _ > Type_predef.type_real 
264 
 Const_array ca > let d = Dimension.mkdim_int loc (List.length ca) in 
265 
let ty = new_var () in 
266 
List.iter (fun e > try_unify ty (type_const loc e) loc) ca; 
267 
Type_predef.type_array d ty 
268 
 Const_tag t > 
269 
if Hashtbl.mem tag_table t 
270 
then 
271 
let tydef = typedef_of_top (Hashtbl.find tag_table t) in 
272 
let tydec = 
273 
if is_user_type tydef.tydef_desc 
274 
then Tydec_const tydef.tydef_id 
275 
else tydef.tydef_desc in 
276 
type_coretype (fun d > ()) tydec 
277 
else raise (Error (loc, Unbound_value ("enum tag " ^ t))) 
278 
 Const_struct fl > 
279 
let ty_struct = new_var () in 
280 
begin 
281 
let used = 
282 
List.fold_left 
283 
(fun acc (l, c) > 
284 
if List.mem l acc 
285 
then raise (Error (loc, Already_bound ("struct field " ^ l))) 
286 
else try_unify ty_struct (type_struct_const_field loc (l, c)) loc; l::acc) 
287 
[] fl in 
288 
try 
289 
let total = List.map fst (get_struct_type_fields (coretype_type ty_struct)) in 
290 
(* List.iter (fun l > Format.eprintf "total: %s@." l) total; 
291 
List.iter (fun l > Format.eprintf "used: %s@." l) used; *) 
292 
let undef = List.find (fun l > not (List.mem l used)) total 
293 
in raise (Error (loc, Unbound_value ("struct field " ^ undef))) 
294 
with Not_found > 
295 
ty_struct 
296 
end 
297 
 Const_string _ > assert false (* string should only appear in annotations *) 
298  
299 
(* The following typing functions take as parameter an environment [env] 
300 
and whether the element being typed is expected to be constant [const]. 
301 
[env] is a pair composed of: 
302 
 a map from ident to type, associating to each ident, i.e. 
303 
variables, constants and (imported) nodes, its type including whether 
304 
it is constant or not. This latter information helps in checking constant 
305 
propagation policy in Lustre. 
306 
 a vdecl list, in order to modify types of declared variables that are 
307 
later discovered to be clocks during the typing process. 
308 
*) 
309 
let check_constant loc const_expected const_real = 
310 
if const_expected && not const_real 
311 
then raise (Error (loc, Not_a_constant)) 
312  
313 
let rec type_add_const env const arg targ = 
314 
if const 
315 
then let d = 
316 
if is_dimension_type targ 
317 
then dimension_of_expr arg 
318 
else Dimension.mkdim_var () in 
319 
let eval_const id = Types.get_static_value (Env.lookup_value (fst env) id) in 
320 
Dimension.eval Basic_library.eval_env eval_const d; 
321 
let real_static_type = Type_predef.type_static d (Types.dynamic_type targ) in 
322 
(match Types.get_static_value targ with 
323 
 None > () 
324 
 Some d' > try_unify targ real_static_type arg.expr_loc); 
325 
real_static_type 
326 
else targ 
327  
328 
(* emulates a subtyping relation between types t and (d : t), 
329 
used during node applications and assignments *) 
330 
and type_subtyping_arg env in_main ?(sub=true) const real_arg formal_type = 
331 
let loc = real_arg.expr_loc in 
332 
let const = const  (Types.get_static_value formal_type <> None) in 
333 
let real_type = type_add_const env const real_arg (type_expr env in_main const real_arg) in 
334 
(*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;*) 
335 
try_unify ~sub:sub formal_type real_type loc 
336  
337 
and type_ident env in_main loc const id = 
338 
type_expr env in_main const (expr_of_ident id loc) 
339  
340 
(* typing an application implies: 
341 
 checking that const formal parameters match real const (maybe symbolic) arguments 
342 
 checking type adequation between formal and real arguments 
343 
An application may embed an homomorphic/internal function, in which case we need to split 
344 
it in many calls 
345 
*) 
346 
and type_appl env in_main loc const f args = 
347 
let targs = List.map (type_expr env in_main const) args in 
348 
if Basic_library.is_internal_fun f && List.exists is_tuple_type targs 
349 
then 
350 
try 
351 
let targs = Utils.transpose_list (List.map type_list_of_type targs) in 
352 
Types.type_of_type_list (List.map (type_simple_call env in_main loc const f) targs) 
353 
with 
354 
Utils.TransposeError (l, l') > raise (Error (loc, WrongMorphism (l, l'))) 
355 
else 
356 
type_dependent_call env in_main loc const f (List.combine args targs) 
357  
358 
(* type a call with possible dependent types. [targs] is here a list of (argument, type) pairs. *) 
359 
and type_dependent_call env in_main loc const f targs = 
360 
let tins, touts = new_var (), new_var () in 
361 
let tfun = Type_predef.type_arrow tins touts in 
362 
type_subtyping_arg env in_main const (expr_of_ident f loc) tfun; 
363 
let tins = type_list_of_type tins in 
364 
if List.length targs <> List.length tins then 
365 
raise (Error (loc, WrongArity (List.length tins, List.length targs))) 
366 
else 
367 
begin 
368 
List.iter2 (fun (a,t) ti > 
369 
let t' = type_add_const env (const  Types.get_static_value ti <> None) a t 
370 
in try_unify ~sub:true ti t' a.expr_loc) targs tins; 
371 
touts 
372 
end 
373  
374 
(* type a simple call without dependent types 
375 
but possible homomorphic extension. 
376 
[targs] is here a list of arguments' types. *) 
377 
and type_simple_call env in_main loc const f targs = 
378 
let tins, touts = new_var (), new_var () in 
379 
let tfun = Type_predef.type_arrow tins touts in 
380 
type_subtyping_arg env in_main const (expr_of_ident f loc) tfun; 
381 
(*Format.eprintf "try unify %a %a@." Types.print_ty tins Types.print_ty (type_of_type_list targs);*) 
382 
try_unify ~sub:true tins (type_of_type_list targs) loc; 
383 
touts 
384  
385 
(** [type_expr env in_main expr] types expression [expr] in environment 
386 
[env], expecting it to be [const] or not. *) 
387 
and type_expr env in_main const expr = 
388 
let resulting_ty = 
389 
match expr.expr_desc with 
390 
 Expr_const c > 
391 
let ty = type_const expr.expr_loc c in 
392 
let ty = Type_predef.type_static (Dimension.mkdim_var ()) ty in 
393 
expr.expr_type < ty; 
394 
ty 
395 
 Expr_ident v > 
396 
let tyv = 
397 
try 
398 
Env.lookup_value (fst env) v 
399 
with Not_found > 
400 
Format.eprintf "Failure in typing expr %a@." Printers.pp_expr expr; 
401 
raise (Error (expr.expr_loc, Unbound_value ("identifier " ^ v))) 
402 
in 
403 
let ty = instantiate (ref []) (ref []) tyv in 
404 
let ty' = 
405 
if const 
406 
then Type_predef.type_static (Dimension.mkdim_var ()) (new_var ()) 
407 
else new_var () in 
408 
try_unify ty ty' expr.expr_loc; 
409 
expr.expr_type < ty; 
410 
ty 
411 
 Expr_array elist > 
412 
let ty_elt = new_var () in 
413 
List.iter (fun e > try_unify ty_elt (type_appl env in_main expr.expr_loc const "uminus" [e]) e.expr_loc) elist; 
414 
let d = Dimension.mkdim_int expr.expr_loc (List.length elist) in 
415 
let ty = Type_predef.type_array d ty_elt in 
416 
expr.expr_type < ty; 
417 
ty 
418 
 Expr_access (e1, d) > 
419 
type_subtyping_arg env in_main true (expr_of_dimension d) Type_predef.type_int; 
420 
let ty_elt = new_var () in 
421 
let d = Dimension.mkdim_var () in 
422 
type_subtyping_arg env in_main const e1 (Type_predef.type_array d ty_elt); 
423 
expr.expr_type < ty_elt; 
424 
ty_elt 
425 
 Expr_power (e1, d) > 
426 
let eval_const id = Types.get_static_value (Env.lookup_value (fst env) id) in 
427 
type_subtyping_arg env in_main true (expr_of_dimension d) Type_predef.type_int; 
428 
Dimension.eval Basic_library.eval_env eval_const d; 
429 
let ty_elt = type_appl env in_main expr.expr_loc const "uminus" [e1] in 
430 
let ty = Type_predef.type_array d ty_elt in 
431 
expr.expr_type < ty; 
432 
ty 
433 
 Expr_tuple elist > 
434 
let ty = new_ty (Ttuple (List.map (type_expr env in_main const) elist)) in 
435 
expr.expr_type < ty; 
436 
ty 
437 
 Expr_ite (c, t, e) > 
438 
type_subtyping_arg env in_main const c Type_predef.type_bool; 
439 
let ty = type_appl env in_main expr.expr_loc const "+" [t; e] in 
440 
expr.expr_type < ty; 
441 
ty 
442 
 Expr_appl (id, args, r) > 
443 
(* application of non internal function is not legal in a constant 
444 
expression *) 
445 
(match r with 
446 
 None > () 
447 
 Some (x, l) > 
448 
check_constant expr.expr_loc const false; 
449 
let expr_x = expr_of_ident x expr.expr_loc in 
450 
let typ_l = 
451 
Type_predef.type_clock 
452 
(type_const expr.expr_loc (Const_tag l)) in 
453 
type_subtyping_arg env in_main ~sub:false const expr_x typ_l); 
454 
let touts = type_appl env in_main expr.expr_loc const id (expr_list_of_expr args) in 
455 
expr.expr_type < touts; 
456 
touts 
457 
 Expr_fby (e1,e2) 
458 
 Expr_arrow (e1,e2) > 
459 
(* fby/arrow is not legal in a constant expression *) 
460 
check_constant expr.expr_loc const false; 
461 
let ty = type_appl env in_main expr.expr_loc const "+" [e1; e2] in 
462 
expr.expr_type < ty; 
463 
ty 
464 
 Expr_pre e > 
465 
(* pre is not legal in a constant expression *) 
466 
check_constant expr.expr_loc const false; 
467 
let ty = type_appl env in_main expr.expr_loc const "uminus" [e] in 
468 
expr.expr_type < ty; 
469 
ty 
470 
 Expr_when (e1,c,l) > 
471 
(* when is not legal in a constant expression *) 
472 
check_constant expr.expr_loc const false; 
473 
let typ_l = Type_predef.type_clock (type_const expr.expr_loc (Const_tag l)) in 
474 
let expr_c = expr_of_ident c expr.expr_loc in 
475 
type_subtyping_arg env in_main ~sub:false const expr_c typ_l; 
476 
let ty = type_appl env in_main expr.expr_loc const "uminus" [e1] in 
477 
expr.expr_type < ty; 
478 
ty 
479 
 Expr_merge (c,hl) > 
480 
(* merge is not legal in a constant expression *) 
481 
check_constant expr.expr_loc const false; 
482 
let typ_in, typ_out = type_branches env in_main expr.expr_loc const hl in 
483 
let expr_c = expr_of_ident c expr.expr_loc in 
484 
let typ_l = Type_predef.type_clock typ_in in 
485 
type_subtyping_arg env in_main ~sub:false const expr_c typ_l; 
486 
expr.expr_type < typ_out; 
487 
typ_out 
488 
in 
489 
Log.report ~level:3 (fun fmt > Format.fprintf fmt "Type of expr %a: %a@." Printers.pp_expr expr Types.print_ty resulting_ty); 
490 
resulting_ty 
491  
492 
and type_branches env in_main loc const hl = 
493 
let typ_in = new_var () in 
494 
let typ_out = new_var () in 
495 
try 
496 
let used_labels = 
497 
List.fold_left (fun accu (t, h) > 
498 
unify typ_in (type_const loc (Const_tag t)); 
499 
type_subtyping_arg env in_main const h typ_out; 
500 
if List.mem t accu 
501 
then raise (Error (loc, Already_bound t)) 
502 
else t :: accu) [] hl in 
503 
let type_labels = get_enum_type_tags (coretype_type typ_in) in 
504 
if List.sort compare used_labels <> List.sort compare type_labels 
505 
then let unbound_tag = List.find (fun t > not (List.mem t used_labels)) type_labels in 
506 
raise (Error (loc, Unbound_value ("branching tag " ^ unbound_tag))) 
507 
else (typ_in, typ_out) 
508 
with Unify (t1, t2) > 
509 
raise (Error (loc, Type_clash (t1,t2))) 
510  
511 
(** [type_eq env eq] types equation [eq] in environment [env] *) 
512 
let type_eq env in_main undefined_vars eq = 
513 
(* Check undefined variables, type lhs *) 
514 
let expr_lhs = expr_of_expr_list eq.eq_loc (List.map (fun v > expr_of_ident v eq.eq_loc) eq.eq_lhs) in 
515 
let ty_lhs = type_expr env in_main false expr_lhs in 
516 
(* Check multiple variable definitions *) 
517 
let define_var id uvars = 
518 
try 
519 
ignore(IMap.find id uvars); 
520 
IMap.remove id uvars 
521 
with Not_found > 
522 
raise (Error (eq.eq_loc, Already_defined id)) 
523 
in 
524 
(* check assignment of declared constant, assignment of clock *) 
525 
let ty_lhs = 
526 
type_of_type_list 
527 
(List.map2 (fun ty id > 
528 
if get_static_value ty <> None 
529 
then raise (Error (eq.eq_loc, Assigned_constant id)) else 
530 
match get_clock_base_type ty with 
531 
 None > ty 
532 
 Some ty > ty) 
533 
(type_list_of_type ty_lhs) eq.eq_lhs) in 
534 
let undefined_vars = 
535 
List.fold_left (fun uvars v > define_var v uvars) undefined_vars eq.eq_lhs in 
536 
(* Type rhs wrt to lhs type with subtyping, i.e. a constant rhs value may be assigned 
537 
to a (always nonconstant) lhs variable *) 
538 
type_subtyping_arg env in_main false eq.eq_rhs ty_lhs; 
539 
undefined_vars 
540  
541  
542 
(* [type_coreclock env ck id loc] types the type clock declaration [ck] 
543 
in environment [env] *) 
544 
let type_coreclock env ck id loc = 
545 
match ck.ck_dec_desc with 
546 
 Ckdec_any  Ckdec_pclock (_,_) > () 
547 
 Ckdec_bool cl > 
548 
let dummy_id_expr = expr_of_ident id loc in 
549 
let when_expr = 
550 
List.fold_left 
551 
(fun expr (x, l) > 
552 
{expr_tag = new_tag (); 
553 
expr_desc= Expr_when (expr,x,l); 
554 
expr_type = new_var (); 
555 
expr_clock = Clocks.new_var true; 
556 
expr_delay = Delay.new_var (); 
557 
expr_loc=loc; 
558 
expr_annot = None}) 
559 
dummy_id_expr cl 
560 
in 
561 
ignore (type_expr env false false when_expr) 
562  
563 
let rec check_type_declaration loc cty = 
564 
match cty with 
565 
 Tydec_clock ty 
566 
 Tydec_array (_, ty) > check_type_declaration loc ty 
567 
 Tydec_const tname > 
568 
if not (Hashtbl.mem type_table cty) 
569 
then raise (Error (loc, Unbound_type tname)); 
570 
 _ > () 
571  
572 
let type_var_decl vd_env env vdecl = 
573 
check_type_declaration vdecl.var_loc vdecl.var_dec_type.ty_dec_desc; 
574 
let eval_const id = Types.get_static_value (Env.lookup_value env id) in 
575 
let type_dim d = 
576 
begin 
577 
type_subtyping_arg (env, vd_env) false true (expr_of_dimension d) Type_predef.type_int; 
578 
Dimension.eval Basic_library.eval_env eval_const d; 
579 
end in 
580 
let ty = type_coretype type_dim vdecl.var_dec_type.ty_dec_desc in 
581 
let ty_status = 
582 
if vdecl.var_dec_const 
583 
then Type_predef.type_static (Dimension.mkdim_var ()) ty 
584 
else ty in 
585 
let new_env = Env.add_value env vdecl.var_id ty_status in 
586 
type_coreclock (new_env,vd_env) vdecl.var_dec_clock vdecl.var_id vdecl.var_loc; 
587 
vdecl.var_type < ty_status; 
588 
new_env 
589  
590 
let type_var_decl_list vd_env env l = 
591 
List.fold_left (type_var_decl vd_env) env l 
592  
593 
let type_of_vlist vars = 
594 
let tyl = List.map (fun v > v.var_type) vars in 
595 
type_of_type_list tyl 
596  
597 
let add_vdecl vd_env vdecl = 
598 
if List.exists (fun v > v.var_id = vdecl.var_id) vd_env 
599 
then raise (Error (vdecl.var_loc, Already_bound vdecl.var_id)) 
600 
else vdecl::vd_env 
601  
602 
let check_vd_env vd_env = 
603 
ignore (List.fold_left add_vdecl [] vd_env) 
604  
605 
(** [type_node env nd loc] types node [nd] in environment env. The 
606 
location is used for error reports. *) 
607 
let type_node env nd loc = 
608 
let is_main = nd.node_id = !Options.main_node in 
609 
let vd_env_ol = nd.node_outputs@nd.node_locals in 
610 
let vd_env = nd.node_inputs@vd_env_ol in 
611 
check_vd_env vd_env; 
612 
let init_env = env in 
613 
let delta_env = type_var_decl_list vd_env init_env nd.node_inputs in 
614 
let delta_env = type_var_decl_list vd_env delta_env nd.node_outputs in 
615 
let delta_env = type_var_decl_list vd_env delta_env nd.node_locals in 
616 
let new_env = Env.overwrite env delta_env in 
617 
let undefined_vars_init = 
618 
List.fold_left 
619 
(fun uvs v > IMap.add v.var_id () uvs) 
620 
IMap.empty vd_env_ol in 
621 
let undefined_vars = 
622 
List.fold_left (type_eq (new_env, vd_env) is_main) undefined_vars_init (get_node_eqs nd) 
623 
in 
624 
(* Typing asserts *) 
625 
List.iter (fun assert_ > 
626 
let assert_expr = assert_.assert_expr in 
627 
type_subtyping_arg (new_env, vd_env) is_main false assert_expr Type_predef.type_bool 
628 
) nd.node_asserts; 
629 

630 
(* check that table is empty *) 
631 
if (not (IMap.is_empty undefined_vars)) then 
632 
raise (Error (loc, Undefined_var undefined_vars)); 
633 
let ty_ins = type_of_vlist nd.node_inputs in 
634 
let ty_outs = type_of_vlist nd.node_outputs in 
635 
let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in 
636 
generalize ty_node; 
637 
(* TODO ? Check that no node in the hierarchy remains polymorphic ? *) 
638 
nd.node_type < ty_node; 
639 
Env.add_value env nd.node_id ty_node 
640  
641 
let type_imported_node env nd loc = 
642 
let new_env = type_var_decl_list nd.nodei_inputs env nd.nodei_inputs in 
643 
let vd_env = nd.nodei_inputs@nd.nodei_outputs in 
644 
check_vd_env vd_env; 
645 
ignore(type_var_decl_list vd_env new_env nd.nodei_outputs); 
646 
let ty_ins = type_of_vlist nd.nodei_inputs in 
647 
let ty_outs = type_of_vlist nd.nodei_outputs in 
648 
let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in 
649 
generalize ty_node; 
650 
(* 
651 
if (is_polymorphic ty_node) then 
652 
raise (Error (loc, Poly_imported_node nd.nodei_id)); 
653 
*) 
654 
let new_env = Env.add_value env nd.nodei_id ty_node in 
655 
nd.nodei_type < ty_node; 
656 
new_env 
657  
658 
let type_top_const env cdecl = 
659 
let ty = type_const cdecl.const_loc cdecl.const_value in 
660 
let d = 
661 
if is_dimension_type ty 
662 
then dimension_of_const cdecl.const_loc cdecl.const_value 
663 
else Dimension.mkdim_var () in 
664 
let ty = Type_predef.type_static d ty in 
665 
let new_env = Env.add_value env cdecl.const_id ty in 
666 
cdecl.const_type < ty; 
667 
new_env 
668  
669 
let type_top_consts env clist = 
670 
List.fold_left type_top_const env clist 
671  
672 
let rec type_top_decl env decl = 
673 
match decl.top_decl_desc with 
674 
 Node nd > ( 
675 
try 
676 
type_node env nd decl.top_decl_loc 
677 
with Error (loc, err) as exc > ( 
678 
if !Options.global_inline then 
679 
Format.eprintf "Type error: failing node@.%a@.@?" 
680 
Printers.pp_node nd 
681 
; 
682 
raise exc) 
683 
) 
684 
 ImportedNode nd > 
685 
type_imported_node env nd decl.top_decl_loc 
686 
 Const c > 
687 
type_top_const env c 
688 
 TypeDef _ > List.fold_left type_top_decl env (consts_of_enum_type decl) 
689 
 Open _ > env 
690  
691 
let type_prog env decls = 
692 
try 
693 
List.fold_left type_top_decl env decls 
694 
with Failure _ as exc > raise exc 
695  
696 
(* Once the Lustre program is fully typed, 
697 
we must get back to the original description of dimensions, 
698 
with constant parameters, instead of unifiable internal variables. *) 
699  
700 
(* The following functions aims at 'unevaluating' dimension expressions occuring in array types, 
701 
i.e. replacing unifiable second_order variables with the original static parameters. 
702 
Once restored in this formulation, dimensions may be meaningfully printed. 
703 
*) 
704 
let uneval_vdecl_generics vdecl = 
705 
if vdecl.var_dec_const 
706 
then 
707 
match get_static_value vdecl.var_type with 
708 
 None > (Format.eprintf "internal error: %a@." Types.print_ty vdecl.var_type; assert false) 
709 
 Some d > Dimension.uneval vdecl.var_id d 
710  
711 
let uneval_node_generics vdecls = 
712 
List.iter uneval_vdecl_generics vdecls 
713  
714 
let uneval_top_generics decl = 
715 
match decl.top_decl_desc with 
716 
 Node nd > 
717 
uneval_node_generics (nd.node_inputs @ nd.node_outputs) 
718 
 ImportedNode nd > 
719 
uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs) 
720 
 Const _ 
721 
 TypeDef _ 
722 
 Open _ > () 
723  
724 
let uneval_prog_generics prog = 
725 
List.iter uneval_top_generics prog 
726  
727 
let rec get_imported_symbol decls id = 
728 
match decls with 
729 
 [] > assert false 
730 
 decl::q > 
731 
(match decl.top_decl_desc with 
732 
 ImportedNode nd when id = nd.nodei_id && decl.top_decl_itf > decl 
733 
 Const c when id = c.const_id && decl.top_decl_itf > decl 
734 
 TypeDef _ > get_imported_symbol (consts_of_enum_type decl @ q) id 
735 
 _ > get_imported_symbol q id) 
736  
737 
let check_env_compat header declared computed = 
738 
uneval_prog_generics header; 
739 
Env.iter declared (fun k decl_type_k > 
740 
let loc = (get_imported_symbol header k).top_decl_loc in 
741 
let computed_t = 
742 
instantiate (ref []) (ref []) 
743 
(try Env.lookup_value computed k 
744 
with Not_found > raise (Error (loc, Declared_but_undefined k))) in 
745 
(*Types.print_ty Format.std_formatter decl_type_k; 
746 
Types.print_ty Format.std_formatter computed_t;*) 
747 
try_unify ~sub:true ~semi:true decl_type_k computed_t loc 
748 
) 
749  
750 
let check_typedef_top decl = 
751 
(*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*) 
752 
(*Printers.pp_var_type_dec_desc (typedef_of_top decl).tydef_id*) 
753 
(*Format.eprintf "%a" Corelang.print_type_table ();*) 
754 
match decl.top_decl_desc with 
755 
 TypeDef ty > 
756 
let owner = decl.top_decl_owner in 
757 
let itf = decl.top_decl_itf in 
758 
let decl' = 
759 
try Hashtbl.find type_table (Tydec_const (typedef_of_top decl).tydef_id) 
760 
with Not_found > raise (Error (decl.top_decl_loc, Declared_but_undefined ("type "^ ty.tydef_id))) in 
761 
let owner' = decl'.top_decl_owner in 
762 
let itf' = decl'.top_decl_itf in 
763 
(match decl'.top_decl_desc with 
764 
 Const _  Node _  ImportedNode _ > assert false 
765 
 TypeDef ty' when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf && (not itf') > () 
766 
 _ > raise (Error (decl.top_decl_loc, Type_mismatch ty.tydef_id))) 
767 
 _ > () 
768  
769 
let check_typedef_compat header = 
770 
List.iter check_typedef_top header 
771  
772 
(* Local Variables: *) 
773 
(* compilecommand:"make C .." *) 
774 
(* End: *) 