Revision 53206908 src/corelang.ml
src/corelang.ml  

1 
(********************************************************************) 

2  1 
(* *) 
3  2 
(* The LustreC compiler toolset / The LustreC Development Team *) 
4  3 
(* Copyright 2012   ONERA  CNRS  INPT *) 
...  ...  
55  54  
56  55 
let mkexpr loc d = 
57  56 
{ expr_tag = Utils.new_tag (); 
57  
58  58 
expr_desc = d; 
59  59 
expr_type = Types.new_var (); 
60  60 
expr_clock = Clocks.new_var true; 
...  ...  
245  245  
246  246 
let top_int_type = mktop (TypeDef {tydef_id = "int"; tydef_desc = Tydec_int}) 
247  247 
let top_bool_type = mktop (TypeDef {tydef_id = "bool"; tydef_desc = Tydec_bool}) 
248 
let top_float_type = mktop (TypeDef {tydef_id = "float"; tydef_desc = Tydec_float})


248 
(* let top_float_type = mktop (TypeDef {tydef_id = "float"; tydef_desc = Tydec_float}) *)


249  249 
let top_real_type = mktop (TypeDef {tydef_id = "real"; tydef_desc = Tydec_real}) 
250  250  
251  251 
let type_table = 
252  252 
Utils.create_hashtable 20 [ 
253  253 
Tydec_int , top_int_type; 
254  254 
Tydec_bool , top_bool_type; 
255 
Tydec_float, top_float_type;


255 
(* Tydec_float, top_float_type; *)


256  256 
Tydec_real , top_real_type 
257  257 
] 
258  258  
...  ...  
270  270 
let rec is_user_type typ = 
271  271 
match typ with 
272  272 
 Tydec_int  Tydec_bool  Tydec_real 
273 
 Tydec_float  Tydec_any  Tydec_const _ > false


273 
(*  Tydec_float *)  Tydec_any  Tydec_const _ > false


274  274 
 Tydec_clock typ' > is_user_type typ' 
275  275 
 _ > true 
276  276  
...  ...  
289  289 
 _ , Tydec_const _ > coretype_equal ty2 ty1 
290  290 
 Tydec_int , Tydec_int 
291  291 
 Tydec_real , Tydec_real 
292 
 Tydec_float , Tydec_float


292 
(*  Tydec_float , Tydec_float *)


293  293 
 Tydec_bool , Tydec_bool > true 
294  294 
 Tydec_clock ty1 , Tydec_clock ty2 > coretype_equal ty1 ty2 
295  295 
 Tydec_array (d1,ty1), Tydec_array (d2, ty2) > Dimension.is_eq_dimension d1 d2 && coretype_equal ty1 ty2 
...  ...  
461  461 
match expr.expr_desc with 
462  462 
 Expr_const c > dimension_of_const expr.expr_loc c 
463  463 
 Expr_ident id > mkdim_ident expr.expr_loc id 
464 
 Expr_appl (f, args, None) when Basic_library.is_internal_fun f >


464 
 Expr_appl (f, args, None) when Basic_library.is_expr_internal_fun expr >


465  465 
let k = Types.get_static_value (Env.lookup_value Basic_library.type_env f) in 
466  466 
if k = None then raise InvalidDimension; 
467  467 
mkdim_appl expr.expr_loc f (List.map dimension_of_expr (expr_list_of_expr args)) 
...  ...  
501  501 
mk_new_name used id 
502  502  
503  503 
let get_var id var_list = 
504 
List.find (fun v > v.var_id = id) var_list


504 
List.find (fun v > v.var_id = id) var_list 

505  505  
506  506 
let get_node_var id node = 
507  507 
get_var id (get_node_vars node) 
...  ...  
579  579 
nodei_stateless = nd.node_dec_stateless; 
580  580 
nodei_spec = nd.node_spec; 
581  581 
nodei_prototype = None; 
582 
nodei_in_lib = None;


582 
nodei_in_lib = [];


583  583 
} 
584  584  
585  585 
(************************************************************************) 
...  ...  
624  624 
let eq_replace_rhs_var pvar fvar eq = 
625  625 
let pvar l = List.exists pvar l in 
626  626 
let rec replace lhs rhs = 
627 
{ rhs with expr_desc = replace_desc lhs rhs.expr_desc } 

628 
and replace_desc lhs rhs_desc = 

627 
{ rhs with expr_desc = 

629  628 
match lhs with 
630  629 
 [] > assert false 
631 
 [_] > if pvar lhs then expr_desc_replace_var fvar rhs_desc else rhs_desc


630 
 [_] > if pvar lhs then expr_desc_replace_var fvar rhs.expr_desc else rhs.expr_desc


632  631 
 _ > 
633 
(match rhs_desc with 

632 
(match rhs.expr_desc with


634  633 
 Expr_tuple tl > 
635  634 
Expr_tuple (List.map2 (fun v e > replace [v] e) lhs tl) 
636 
 Expr_appl (f, arg, None) when Basic_library.is_internal_fun f >


635 
 Expr_appl (f, arg, None) when Basic_library.is_expr_internal_fun rhs >


637  636 
let args = expr_list_of_expr arg in 
638  637 
Expr_appl (f, expr_of_expr_list arg.expr_loc (List.map (replace lhs) args), None) 
639  638 
 Expr_array _ 
...  ...  
643  642 
 Expr_ident _ 
644  643 
 Expr_appl _ > 
645  644 
if pvar lhs 
646 
then expr_desc_replace_var fvar rhs_desc 

647 
else rhs_desc 

645 
then expr_desc_replace_var fvar rhs.expr_desc


646 
else rhs.expr_desc


648  647 
 Expr_ite (c, t, e) > Expr_ite (replace lhs c, replace lhs t, replace lhs e) 
649  648 
 Expr_arrow (e1, e2) > Expr_arrow (replace lhs e1, replace lhs e2) 
650  649 
 Expr_fby (e1, e2) > Expr_fby (replace lhs e1, replace lhs e2) 
...  ...  
654  653 
 Expr_merge (i, hl) > let i' = if pvar lhs then fvar i else i 
655  654 
in Expr_merge (i', List.map (fun (t, h) > (t, replace lhs h)) hl) 
656  655 
) 
656 
} 

657  657 
in { eq with eq_rhs = replace eq.eq_lhs eq.eq_rhs } 
658  658  
659  659  
...  ...  
792  792 
Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog 
793  793  
794  794 
let pp_error fmt = function 
795 
 Main_not_found >


796 
fprintf fmt "cannot compile node %s: could not find the node definition.@."


797 
!Options.main_node


795 
Main_not_found >


796 
fprintf fmt "could not find the definition of main node %s.@."


797 
!Global.main_node


798  798 
 Main_wrong_kind > 
799  799 
fprintf fmt 
800 
"name %s does not correspond to a (nonimported) node definition.@."


801 
!Options.main_node


800 
"name %s does not correspond to a valid main node definition.@."


801 
!Global.main_node


802  802 
 No_main_specified > 
803 
fprintf fmt "no main node specified.@."


803 
fprintf fmt "no main node specified (use node option)@."


804  804 
 Unbound_symbol sym > 
805  805 
fprintf fmt 
806  806 
"%s is undefined.@." 
...  ...  
811  811 
sym 
812  812 
 Unknown_library sym > 
813  813 
fprintf fmt 
814 
"impossible to load library %s.lusic.@.Please compile the corresponding interface or source file.@."


814 
"impossible to load library %s.lusic@.Please compile the corresponding interface or source file.@." 

815  815 
sym 
816  816 
 Wrong_number sym > 
817  817 
fprintf fmt 
818 
"library %s.lusic has a different version number and may crash compiler.@.Please recompile the corresponding interface or source file.@." 

818 
"library %s.lusic has a different version number and may crash the compiler.@.Please recompile the corresponding interface or source file.@."


819  819 
sym 
820  820  
821  821 
(* filling node table with internal functions *) 
...  ...  
844  844 
nodei_stateless = Types.get_static_value ty <> None; 
845  845 
nodei_spec = spec; 
846  846 
nodei_prototype = None; 
847 
nodei_in_lib = None;


847 
nodei_in_lib = [];


848  848 
}) 
849  849  
850  850 
let add_internal_funs () = 
...  ...  
927  927  
928  928 
*) 
929  929 
let rec get_expr_calls nodes e = 
930 
get_calls_expr_desc nodes e.expr_desc 

931 
and get_calls_expr_desc nodes expr_desc = 

932  930 
let get_calls = get_expr_calls nodes in 
933 
match expr_desc with 

931 
match e.expr_desc with


934  932 
 Expr_const _ 
935  933 
 Expr_ident _ > Utils.ISet.empty 
936  934 
 Expr_tuple el 
...  ...  
944  942 
 Expr_fby (e1, e2) > Utils.ISet.union (get_calls e1) (get_calls e2) 
945  943 
 Expr_merge (_, hl) > List.fold_left (fun accu (_, h) > Utils.ISet.union accu (get_calls h)) Utils.ISet.empty hl 
946  944 
 Expr_appl (i, e', i') > 
947 
if Basic_library.is_internal_fun i then


945 
if Basic_library.is_expr_internal_fun e then


948  946 
(get_calls e') 
949  947 
else 
950  948 
let calls = Utils.ISet.add i (get_calls e') in 
Also available in: Unified diff