diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 7d742f479278b4aeb4ccde160a65e8d5ff5bd188..91ac961fe4b699c3db0b9e5830492abd42c8e909 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 03/03/2009 (at 17:43) by Erwan Jahier> *)
+(** Time-stamp: <modified the 04/03/2009 (at 10:29) by Erwan Jahier> *)
open Lxm
@@ -342,13 +342,13 @@ and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
match prov_const_eff, body_const_eff with
| Eff.Extern_const_eff (_), _ -> assert false
| Eff.Abstract_const_eff (id, teff, v, is_exported),
- Eff.Abstract_const_eff (body_id, body_teff, body_v, body_is_exported)
+ Eff.Abstract_const_eff (body_id, body_teff, body_v, body_is_exported)
->
assert false
(* indeed, how can a body constant be extern and have a value? *)
| Eff.Abstract_const_eff (id, teff, v, is_exported),
- Eff.Extern_const_eff (body_id, body_teff)
+ Eff.Extern_const_eff (body_id, body_teff)
->
if (id <> cn) then assert false
else if not (Eff.type_are_compatible teff body_teff) then
@@ -380,8 +380,8 @@ and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
raise(Compile_error (const_def.src, " constant values mismatch"))
else
Eff.Abstract_const_eff (id, teff, body_const_eff, is_exported)
-
-
+
+
| Eff.Enum_const_eff (_, _), _
| Eff.Bool_const_eff _, _
@@ -389,7 +389,7 @@ and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
| Eff.Real_const_eff _, _
| Eff.Struct_const_eff (_,_), _
| Eff.Array_const_eff (_,_), _
- ->
+ ->
if prov_const_eff = body_const_eff then
body_const_eff
else
@@ -463,7 +463,7 @@ and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
| Struct_type_eff(_) -> true
| Any | Overload | Bool_type_eff | Int_type_eff | Real_type_eff
| External_type_eff(_) | Abstract_type_eff(_) | Enum_type_eff(_)
- -> false
+ -> false
in
if
(not provide_flag)
@@ -502,29 +502,29 @@ and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
| ExternalConst (id, texp, val_opt) ->
let lid = Ident.make_long currpack id in
let teff = GetEff.typ id_solver texp in
- if provide_flag then
- match val_opt with
- | None ->
- (* we put a fake value here as we don't know yet the
- concrete value. this will be filled in
- const_check_interface_do. I could have put an option
- type, but that would make quite a lot of noise in the
- remaining...
- *)
- Abstract_const_eff(lid, teff, Int_const_eff (-666), false)
- | Some c ->
- let ceff = match EvalConst.f id_solver c with
- | [ceff] -> ceff
- | _ -> assert false
- in
- Abstract_const_eff(lid, teff, ceff, true)
-
- else
- (match val_opt with
- | None -> Extern_const_eff(lid, teff)
- | Some c -> assert false
- (* indeed, how can a body constant be extern and have a value? *)
- )
+ if provide_flag then
+ match val_opt with
+ | None ->
+ (* we put a fake value here as we don't know yet the
+ concrete value. this will be filled in
+ const_check_interface_do. I could have put an option
+ type, but that would make quite a lot of noise in the
+ remaining...
+ *)
+ Abstract_const_eff(lid, teff, Int_const_eff (-666), false)
+ | Some c ->
+ let ceff = match EvalConst.f id_solver c with
+ | [ceff] -> ceff
+ | _ -> assert false
+ in
+ Abstract_const_eff(lid, teff, ceff, true)
+
+ else
+ (match val_opt with
+ | None -> Extern_const_eff(lid, teff)
+ | Some c -> assert false
+ (* indeed, how can a body constant be extern and have a value? *)
+ )
| EnumConst (id, texp) ->
Enum_const_eff ((Ident.make_long currpack id), GetEff.typ id_solver texp)
@@ -539,14 +539,14 @@ and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
if (tdecl = teff ) then ceff else
raise
(Compile_error (const_def.src, Printf.sprintf
- " this constant is declared as '%s' but evaluated as '%s'"
- (LicDump.string_of_type_eff4msg tdecl)
- (LicDump.string_of_type_eff4msg teff)
+ " this constant is declared as '%s' but evaluated as '%s'"
+ (LicDump.string_of_type_eff4msg tdecl)
+ (LicDump.string_of_type_eff4msg teff)
)))
)
| [] -> assert false (* should not occur *)
| _::_ -> raise (Compile_error(const_def.src,
- "bad constant value: tuple not allowed"))
+ "bad constant value: tuple not allowed"))
)
in
let is_struct_or_array = match const_eff with
@@ -559,8 +559,8 @@ and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
in
if
(not provide_flag
- && (not (!Global.expand_structs & is_struct_or_array))
- && not !Global.ec (* ec does not need constant decl *)
+ && (not (!Global.expand_structs & is_struct_or_array))
+ && not !Global.ec (* ec does not need constant decl *)
) || is_extern_const
then
output_string !Global.oc (LicDump.const_decl cn const_eff);
@@ -625,7 +625,7 @@ and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
else if
(List.exists2 type_is_not_comp
prov_node_exp_eff.outlist_eff body_node_exp_eff.outlist_eff)
- (* ougth to be checked above: well, it eats no bread to keep that check *)
+ (* ougth to be checked above: well, it eats no bread to keep that check *)
then
let msg = msg_prefix ^ "bad output profile. \n*** " ^
(String.concat "*" (List.map str_of_var prov_node_exp_eff.outlist_eff)) ^
@@ -668,14 +668,14 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
lxm,
"\n*** '"^(Ident.string_of_idref id)^
"': Unknown variable.\n*** Current variables are: " ^
- (Hashtbl.fold
- (fun id vi_eff acc ->
- acc ^ (Format.sprintf
- "\n\t%s" (LicDump.string_of_var_info_eff4msg vi_eff))
- )
- local_env.lenv_vars
- ""
- ))));
+ (Hashtbl.fold
+ (fun id vi_eff acc ->
+ acc ^ (Format.sprintf
+ "\n\t%s" (LicDump.string_of_var_info_eff4msg vi_eff))
+ )
+ local_env.lenv_vars
+ ""
+ ))));
id2const =
(fun id lxm ->
try lookup_const local_env id lxm
@@ -689,10 +689,10 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
id2node =
(fun id sargs lxm ->
(try
- let node_id, inlist, outlist = lookup_node local_env id sargs lxm in
- let node_id = Ident.idref_of_long node_id in
- solve_node_idref this symbols provide_flag pack_name node_id [] lxm
-(* node_check this (node_id,[]) lxm *)
+ let node_id, inlist, outlist = lookup_node local_env id sargs lxm in
+ let node_id = Ident.idref_of_long node_id in
+ solve_node_idref this symbols provide_flag pack_name node_id [] lxm
+ (* node_check this (node_id,[]) lxm *)
with
Not_found ->
@@ -735,7 +735,7 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
let (sort_vars : Ident.t list -> Ident.t list) =
fun l ->
(* I cannot use List.sort as I only have a partial order on vars
- -> hence I perform a topological sort *)
+ -> hence I perform a topological sort *)
let rec depends_on v1 v2 =
match (find_var_info lxm vars v1).it.var_clock with
| Base -> false
@@ -763,7 +763,7 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
(Ident.to_string v) ^ " depends on " ^
(Ident.to_string v2) ^ ", which depends on " ^
(Ident.to_string v))
- )
+ )
else
let l1,l2 = List.partition (fun v -> v=v2) l in
if l1 = [] then
@@ -804,44 +804,84 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
is_polym_eff = !is_polymorphic
}
in
- let (make_alias_node : Eff.node_exp -> Eff.node_exp) =
- fun aliased_node ->
- (* builds a node that calls the aliased node. It looks like:
- node alias_node( ins ) returns ( outs );
- let
- outs = aliased_node(ins);
- tel
+ let (make_alias_node : Eff.node_exp -> node_vars option -> Eff.node_exp) =
+ fun aliased_node vars_opt ->
+ (* builds a node that calls the aliased node. It looks like:
+ node alias_node(ins) returns (outs);
+ let
+ outs = aliased_node(ins);
+ tel
+
+ When instanciating models with polymorphic operators, it
+ may happen that some exported user nodes become
+ polymorphic (via node alias precisely). But in that case,
+ a non-polymorphic profile is given in the package provided
+ part. In such a case, we can use the types of the provided
+ part (itl and otl) instead of the polymorphic ones.
*)
- let (outs:Eff.left list) =
- List.map (fun vi -> LeftVarEff (vi, lxm)) aliased_node.outlist_eff
+ let (il,ol) = Eff.profile_of_node_exp aliased_node in
+ let (il_decl, ol_decl) =
+ match vars_opt with
+ | None -> (il,ol) (* no type profile is declared; we use the alias one *)
+ | Some vars ->
+ (* a type profile is declared; let's check there are compatible *)
+ let vi_il, vi_ol =
+ List.map (fun id -> find_var_info lxm vars id) vars.inlist,
+ List.map (fun id -> find_var_info lxm vars id) vars.outlist
+ in
+ let aux vi = GetEff.typ node_id_solver vi.it.var_type in
+ let (il_decl, ol_decl) = List.map aux vi_il, List.map aux vi_ol in
+ let i_unif_res = UnifyType.f il_decl il
+ and o_unif_res = UnifyType.f ol_decl ol
+ in
+ (match i_unif_res with
+ | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
+ | UnifyType.Equal -> ()
+ | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ );
+ (match o_unif_res with
+ | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
+ | UnifyType.Equal -> ()
+ | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ );
+ (* ok, there are compatible. We use the declared profile. *)
+ (il_decl, ol_decl)
+ in
+ let instanciate_var_info vi t = { vi with var_type_eff = t } in
+ let vil = List.map2 instanciate_var_info aliased_node.inlist_eff il_decl
+ and vol = List.map2 instanciate_var_info aliased_node.outlist_eff ol_decl in
+ let (outs:Eff.left list) = List.map (fun vi -> LeftVarEff (vi, lxm)) vol
and (aliased_node_call : Eff.val_exp) =
CallByPosEff(
- (Lxm.flagit (Eff.CALL(Lxm.flagit aliased_node lxm)) lxm,
- OperEff
- (List.map
- (fun vi -> (* build operands*)
- let ve = CallByPosEff(
- Lxm.flagit (Eff.IDENT
- (Ident.to_idref vi.var_name_eff)) lxm, OperEff [])
- in
- EvalType.add ve [vi.var_type_eff];
- EvalClock.add ve [vi.var_clock_eff];
- ve
- )
- aliased_node.inlist_eff)))
+ (Lxm.flagit (Eff.CALL(Lxm.flagit aliased_node lxm)) lxm,
+ OperEff
+ (List.map
+ (fun vi -> (* build operands*)
+ let ve = CallByPosEff(
+ Lxm.flagit (Eff.IDENT
+ (Ident.to_idref vi.var_name_eff)) lxm, OperEff [])
+ in
+ EvalType.add ve [vi.var_type_eff];
+ EvalClock.add ve [vi.var_clock_eff];
+ ve
+ )
+ vil)))
in
let tl = List.map Eff.type_of_left outs in
let cl = List.map (fun l -> (Eff.var_info_of_left l).var_clock_eff) outs in
- EvalType.add aliased_node_call tl;
- EvalClock.add aliased_node_call cl;
+ EvalType.add aliased_node_call tl;
+ EvalClock.add aliased_node_call cl;
{
aliased_node with
node_key_eff = nk;
+ inlist_eff = vil;
+ outlist_eff = vol;
loclist_eff = None;
def_eff = BodyEff(
{ asserts_eff = [];
eqs_eff = [Lxm.flagit (outs, aliased_node_call) lxm]
});
+ is_polym_eff = List.exists Eff.is_polymorphic (il_decl@ol_decl);
}
in
(* let's go *)
@@ -888,110 +928,48 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
->
raise (Compile_error (lxm, "can not alias this operator, sorry"))
(* does it make sense to alias when, pre, etc? *)
- in
- let (alias_node : Eff.node_exp) = make_alias_node aliased_node in
-
- (* update the local_env table *)
- let _ =
- let update_local_env_table vi =
- Hashtbl.add local_env.lenv_vars vi.var_name_eff vi
in
- List.iter update_local_env_table alias_node.inlist_eff;
- List.iter update_local_env_table alias_node.outlist_eff;
- match alias_node.loclist_eff with
- None -> () | Some l -> List.iter update_local_env_table l;
- in
- let instanciate_node n itl otl =
- (** replace the types i/o of n by [itl] (input type list)
- and [otl] (output type list).
-
- Indeed, when instanciating models with polymorphic
- operators, it may happen that some exported user
- nodes become polymorphic (via node alias
- precisely). But in that case, a non-polymorphic
- profile is given in the package provided part. In
- such a case, we can use the types of the provided
- part (itl and otl) instead of the polymorphic ones.
-
- The tricky part is that it is not enough to modify the
- inlist_eff and the outlist_eff fields: i/o vars (var_info) migth
- appear in left part.
-
- It also changes the is_polym_eff field.
-
- I hope this is all...
- *)
- let instanciate_var_info vi t = (vi, { vi with var_type_eff = t }) in
- let instanciate_type t1 t2 = match t1 with Any | Overload -> t2 | _ -> t1
+ let (alias_node : Eff.node_exp) =
+ try make_alias_node aliased_node node_def.it.vars
+ with Not_found -> assert false (* defense against List.assoc *)
in
- let si = List.map2 instanciate_var_info n.inlist_eff itl
- and so = List.map2 instanciate_var_info n.outlist_eff otl in
- let s = List.rev_append si so in
- let instanciate_left left =
- let rec aux = function
- | LeftVarEff (vi,lxm) ->
- let nvi = List.assoc vi s in
- LeftVarEff(nvi,lxm), nvi.var_type_eff
- | LeftFieldEff(l,id,t) ->
- let nl,nt = aux l in
- LeftFieldEff(nl, id, instanciate_type t nt), nt
- | LeftArrayEff(l,i,t) ->
- let nl,nt = aux l in
- LeftArrayEff(nl, i, instanciate_type t nt), nt
- | LeftSliceEff(l,si,t) ->
- let nl,nt = aux l in
- LeftSliceEff(nl, si, instanciate_type t nt), nt
+
+ (* update the local_env table *)
+ let _ =
+ let update_local_env_table vi =
+ Hashtbl.add local_env.lenv_vars vi.var_name_eff vi
in
- fst (aux left)
+ List.iter update_local_env_table alias_node.inlist_eff;
+ List.iter update_local_env_table alias_node.outlist_eff;
+ match alias_node.loclist_eff with
+ None -> () | Some l -> List.iter update_local_env_table l;
in
- let instanciate_eq { it = (ll,ve); src = lxm } =
- { it = (List.map instanciate_left ll,ve); src = lxm }
- in
- { n with
- inlist_eff = List.map2
- (fun vi texp -> { vi with var_type_eff = texp }) n.inlist_eff itl;
-
- outlist_eff = List.map2
- (fun vi texp -> { vi with var_type_eff = texp }) n.outlist_eff otl;
-
- def_eff = (match n.def_eff with
- | ExternEff | AbstractEff -> n.def_eff
- | BodyEff nb -> BodyEff
- { nb with eqs_eff = List.map instanciate_eq nb.eqs_eff });
-
- is_polym_eff = List.exists Eff.is_polymorphic (itl @ otl);
- }
- in
- (* end of [instanciate_node] *)
- (* Check that the declared profile (if any) matches with the alias *)
- match node_def.it.vars with
- | None -> alias_node
- | Some vars ->
- let vi_il, vi_ol =
- List.map (fun id -> find_var_info lxm vars id) vars.inlist,
- List.map (fun id -> find_var_info lxm vars id) vars.outlist
- in
- let aux vi = GetEff.typ node_id_solver vi.it.var_type
- in
- let (il,ol) = Eff.profile_of_node_exp alias_node in
- let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in
- let i_unif_res = UnifyType.f il_exp il
- and o_unif_res = UnifyType.f ol_exp ol
- in
- (match i_unif_res with
- | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
- | UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
- );
- (match o_unif_res with
- | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
- | UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
- );
- try
- instanciate_node alias_node il_exp ol_exp
- with
- Not_found -> assert false (* defense against List.assoc *)
+ (* Check that the declared profile (if any) matches with the alias *)
+ match node_def.it.vars with
+ | None -> alias_node
+ | Some vars ->
+ let vi_il, vi_ol =
+ List.map (fun id -> find_var_info lxm vars id) vars.inlist,
+ List.map (fun id -> find_var_info lxm vars id) vars.outlist
+ in
+ let aux vi = GetEff.typ node_id_solver vi.it.var_type
+ in
+ let (il,ol) = Eff.profile_of_node_exp alias_node in
+ let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in
+ let i_unif_res = UnifyType.f il_exp il
+ and o_unif_res = UnifyType.f ol_exp ol
+ in
+ (match i_unif_res with
+ | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
+ | UnifyType.Equal -> ()
+ | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ );
+ (match o_unif_res with
+ | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
+ | UnifyType.Equal -> ()
+ | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ );
+ alias_node
)
(* End Alias *)
in
@@ -1042,7 +1020,7 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
(* nb: we print res_struct, but we return res, because the structure and
array expansion modify the node profiles.
- *)
+ *)
res
diff --git a/src/test/Makefile b/src/test/Makefile
index 907480a8471ab6a4cd75eea97bc6943332566e7f..b878b39a4186bd487e01e81850a60744b880bffa 100644
--- a/src/test/Makefile
+++ b/src/test/Makefile
@@ -99,7 +99,7 @@ test_ec:
(ec2c /tmp/xx.ec >> test_ec.res 2>&1 && echo -n "ok ") || echo " KO!";\
done; \
diff -u test_ec.res.exp test_ec.res > test_ec.diff || \
- (cat test.diff ; echo "cf test.diff"; exit 1)
+ (cat test_ec.diff ; echo "cf test_ec.diff"; exit 1)
utest_ec:
@@ -115,7 +115,7 @@ test_lv4:
(lus2ec /tmp/xx.lus `lusinfo /tmp/xx.lus nodes | head -n 1` >> test_lv4.res 2>&1 && echo -n "ok ") || echo " KO!";\
done; \
diff -u test_lv4.res.exp test_lv4.res > test_lv4.diff || \
- (cat test.diff ; echo "cf test.diff"; exit 1)
+ (cat test_lv4.diff ; echo "cf test_lv4.diff"; exit 1)
utest_lv4: