diff --git a/src/ast2lic.ml b/src/ast2lic.ml
index e8e7e2a8bdfb2985cec24fa44a0f749abb6d2201..1bc54607676abf74eec1aa0cf32172e3b7696ee2 100644
--- a/src/ast2lic.ml
+++ b/src/ast2lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 07:53) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 14:58) by Erwan Jahier> *)
open Lxm
@@ -353,19 +353,27 @@ and (translate_val_exp : Lic.id_solver -> UnifyClock.subst -> AstCore.val_exp
fun id_solver s ve ->
let s, vef_core, lxm =
match ve with
- | MERGE_n(id, cl) ->
+ | Merge_n(id, cl) ->
let lxm_ve = id.src in
let s, cl =
List.fold_left
(fun (s,cl) (id,ve) ->
let s, ve = translate_val_exp id_solver s ve in
- let long = Ident.long_of_idref id.it in
- s,(flagit long id.src, ve)::cl
+ let const = id_solver.id2const id.it id.src in
+ s,(flagit const id.src, ve)::cl
)
(s, [])
cl
in
s, Lic.Merge(id, List.rev cl), lxm_ve
+ | Merge_bool_n(id, t, f) ->
+ let lxm_ve = id.src in
+ let s,case_true = translate_val_exp id_solver s t in
+ let s,case_false = translate_val_exp id_solver s f in
+ let case_true = (flagit (Bool_const_eff true) lxm_ve, case_true) in
+ let case_false = (flagit (Bool_const_eff false) lxm_ve, case_false) in
+ s, Lic.Merge(id, [case_true; case_false]), lxm_ve
+
| CallByName(by_name_op, field_list) ->
let s,fl = List.fold_left
(fun (s,fl) f ->
diff --git a/src/astCore.ml b/src/astCore.ml
index 58e2d34fca84a4c1bf03a8af8a42b5ceb5b1871c..4138f7412191174d2cf75794c41d668461cbaf7c 100644
--- a/src/astCore.ml
+++ b/src/astCore.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 07:53) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 14:59) by Erwan Jahier> *)
(** (Raw) Abstract syntax tree of source Lustre Core programs. *)
@@ -124,7 +124,8 @@ and by_pos_op =
and val_exp =
| CallByPos of (by_pos_op srcflagged * operands)
| CallByName of (by_name_op srcflagged * (Ident.t srcflagged * val_exp) list)
- | MERGE_n of Ident.t srcflagged * (Ident.idref srcflagged * val_exp) list
+ | Merge_n of Ident.t srcflagged * (Ident.idref srcflagged * val_exp) list
+ | Merge_bool_n of Ident.t srcflagged * val_exp * val_exp
and operands = Oper of val_exp list
(* Virer cet Oper ? Non, sinon ca boucle... *)
@@ -210,4 +211,5 @@ let string_of_var_nature = function
let lxm_of_val_exp = function
| CallByPos(op,_) -> op.src
| CallByName(op,_) -> op.src
- | MERGE_n(id,_) -> id.src
+ | Merge_n(id,_)
+ | Merge_bool_n(id,_,_) -> id.src
diff --git a/src/astRecognizePredef.ml b/src/astRecognizePredef.ml
index 2fef1dca6ada10a1415a9702bf905bfc152692ad..842fbc75c3199a8332c5816ecd30620bd138bbd5 100644
--- a/src/astRecognizePredef.ml
+++ b/src/astRecognizePredef.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 07:54) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 15:00) by Erwan Jahier> *)
let (get_predef : Ident.idref -> AstPredef.op option) =
@@ -114,10 +114,11 @@ and r_val_exp = function
CallByPos(flag2 r_by_pos_op by_pos_op, Oper (List.map r_val_exp vel))
| CallByName(by_name_op, args) ->
CallByName(by_name_op, List.map (fun (id, ve) -> id, r_val_exp ve) args)
- | MERGE_n (ec,cl) ->
+ | Merge_n (ec,cl) ->
let cl = List.map (fun (id,ve) -> (id, r_val_exp ve)) cl in
- MERGE_n (ec,cl)
-
+ Merge_n (ec,cl)
+ | Merge_bool_n(id, t, f) -> Merge_bool_n(id, r_val_exp t, r_val_exp f)
+
and r_item_info_flg_list = function
| None -> None
| Some iil -> Some (List.map (flag r_item_info) iil)
diff --git a/src/astTab.ml b/src/astTab.ml
index 662fcc4b0c4fa6315a7adcf51408e57d0e70bf3e..7f9945beedbdc3fcb2b8a2a0b4632d5880cd6a9b 100644
--- a/src/astTab.ml
+++ b/src/astTab.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:34) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 14:22) by Erwan Jahier> *)
(**
Table des infos sources : une couche au dessus de AstV6 pour mieux
@@ -143,33 +143,33 @@ let init_user_items (this: pack_mng) = (
(** Exportation D'une const_info *)
let export_const (s:Ident.t) (xci: AstCore.const_info srcflagged) =
- Verbose.printf ~level:3 " export const %s\n" (Ident.to_string s);
- put_in_tab "const" this.pm_user_items
- (ConstItem s)
- (Lxm.flagit (Ident.make_long pname s) xci.src)
+ Verbose.printf ~level:3 " export const %s\n" (Ident.to_string s);
+ put_in_tab "const" this.pm_user_items
+ (ConstItem s)
+ (Lxm.flagit (Ident.make_long pname s) xci.src)
in
-
+
(** Exportation D'un type_info *)
let export_type (s: Ident.t) (xti: AstCore.type_info srcflagged) =
( match (xti.it) with
- | EnumType (_, ecl) -> (
+ | EnumType (_, ecl) -> (
(* Cas particulier des types enums *)
(* on exporte les constantes ... *)
- let treat_enum_const ec =
- let s = ec.it in
- let lxm = ec.src in
- Verbose.printf ~level:3 " export enum const %s\n" (Ident.to_string s);
- put_in_tab "const" this.pm_user_items
- (ConstItem s)
- (Lxm.flagit (Ident.make_long pname s) lxm)
- in
- List.iter treat_enum_const ecl
- )
- | ExternalType _
- | AliasedType _
- | StructType _
- | ArrayType _
- -> ()
+ let treat_enum_const ec =
+ let s = ec.it in
+ let lxm = ec.src in
+ Verbose.printf ~level:3 " export enum const %s\n" (Ident.to_string s);
+ put_in_tab "const" this.pm_user_items
+ (ConstItem s)
+ (Lxm.flagit (Ident.make_long pname s) lxm)
+ in
+ List.iter treat_enum_const ecl
+ )
+ | ExternalType _
+ | AliasedType _
+ | StructType _
+ | ArrayType _
+ -> ()
);
Verbose.printf ~level:3 " export type %s\n" (Ident.to_string s);
put_in_tab "type" this.pm_user_items
@@ -186,23 +186,24 @@ let init_user_items (this: pack_mng) = (
in
let pg = this.pm_actual_src in
- match pg.pg_provides with
- | None ->
+
+ match pg.pg_provides with
+ | None ->
(* On Exporte Tout Tel Quel *)
- Hashtbl.iter export_type pg.pg_body.pk_type_table ;
- Hashtbl.iter export_const pg.pg_body.pk_const_table ;
- Hashtbl.iter export_node pg.pg_body.pk_node_table ;
- | Some spflg ->
+ Hashtbl.iter export_type pg.pg_body.pk_type_table ;
+ Hashtbl.iter export_const pg.pg_body.pk_const_table ;
+ Hashtbl.iter export_node pg.pg_body.pk_node_table ;
+ | Some spflg ->
(* On Exporte Les Provides *)
- let treat_prov x =
- let lxm = x.src in
- let s = Lxm.id lxm in
- match (x.it) with
- TypeInfo xti -> export_type s (Lxm.flagit xti lxm)
- | ConstInfo xci -> export_const s (Lxm.flagit xci lxm)
- | NodeInfo xoi -> export_node s (Lxm.flagit xoi lxm)
- in
- List.iter treat_prov spflg
+ let treat_prov x =
+ let lxm = x.src in
+ let s = Lxm.id lxm in
+ match (x.it) with
+ TypeInfo xti -> export_type s (Lxm.flagit xti lxm)
+ | ConstInfo xci -> export_const s (Lxm.flagit xci lxm)
+ | NodeInfo xoi -> export_node s (Lxm.flagit xoi lxm)
+ in
+ List.iter treat_prov spflg
)
(*
@@ -216,23 +217,23 @@ let create_pack_mng
(pgiven : AstV6.pack_given)
= (
(* la table pm_provide_stab n'est créée que si besoin *)
- let ppstab = match pgiven.pg_provides with
- None -> None
- | Some _ -> Some (AstTabSymbol.create ())
- in
- let res =
- {
- pm_lxm = pdata.src ;
- pm_raw_src = pdata.it;
- pm_actual_src = pgiven;
- pm_user_items = Hashtbl.create 50;
- pm_provide_stab = ppstab;
- pm_body_stab = AstTabSymbol.create ();
- }
- in
- init_user_items res;
- res
- )
+ let ppstab = match pgiven.pg_provides with
+ None -> None
+ | Some _ -> Some (AstTabSymbol.create ())
+ in
+ let res =
+ {
+ pm_lxm = pdata.src ;
+ pm_raw_src = pdata.it;
+ pm_actual_src = pgiven;
+ pm_user_items = Hashtbl.create 50;
+ pm_provide_stab = ppstab;
+ pm_body_stab = AstTabSymbol.create ();
+ }
+ in
+ init_user_items res;
+ res
+)
@@ -259,9 +260,9 @@ let rec (create : AstV6.pack_or_model list -> t) =
}
in
Verbose.printf ~level:3 "*** AstTab.create pass 1\n";
- (* passe 1 *)
+ (* passe 1 *)
init_raw_tabs res sl ;
- (* passe 2 *)
+ (* passe 2 *)
Verbose.printf ~level:3 "*** AstTab.create pass 2\n";
let init_pack_mng pname pdata = (
Verbose.printf ~level:3 " init pack %s\n" (Ident.pack_name_to_string pname);
@@ -271,10 +272,10 @@ let rec (create : AstV6.pack_or_model list -> t) =
(create_pack_mng pdata pg)
) in
Hashtbl.iter init_pack_mng res.st_raw_pack_tab ;
- (* passe 3 *)
+ (* passe 3 *)
Verbose.printf ~level:3 "*** AstTab.create pass 3\n";
Hashtbl.iter (init_pack_mng_stabs res) res.st_pack_mng_tab ;
- (* resultat *)
+ (* resultat *)
Verbose.printf ~level:3 "*** AstTab.create done\n";
res
and
@@ -284,7 +285,7 @@ and
(* on itère pour chaque pack_or_model : *)
let treat_ns ns =
match ns with
- (* cas d'un package *)
+ (* cas d'un package *)
| AstV6.NSPack pi ->
let lxm = pi.Lxm.src in
let nme = (Ident.pack_name_of_string (Lxm.str lxm)) in
@@ -297,31 +298,31 @@ and
in
List.iter treat_ns sl
and
-(***** PASSE 3 *****)
-(* Essentiellement le remplissage des champs de pack_mng :
+ (***** PASSE 3 *****)
+ (* Essentiellement le remplissage des champs de pack_mng :
- pm_provide_stab : AstTabSymbol.t
- table qui permettra de résoudre les refs simples
- à l'intérieur de la partie provides.
+ pm_provide_stab : AstTabSymbol.t
+ table qui permettra de résoudre les refs simples
+ à l'intérieur de la partie provides.
- pm_body_stab : AstTabSymbol.t ;
- table qui permettra de résoudre les refs simples
- à l'intérieur de la partie body.
+ pm_body_stab : AstTabSymbol.t ;
+ table qui permettra de résoudre les refs simples
+ à l'intérieur de la partie body.
- N.B. s'il n'y a pas de provides explicite, on construit
- une unique table qui sert pour les deux !
+ N.B. s'il n'y a pas de provides explicite, on construit
+ une unique table qui sert pour les deux !
- Comment ça marche :
- - on traite en premier les éventuels "use", (= open de ocaml)
- - puis les déclarations locales qui peuvent éventuellement
- masquer les précédentes (warning ?)
-*)
+ Comment ça marche :
+ - on traite en premier les éventuels "use", (= open de ocaml)
+ - puis les déclarations locales qui peuvent éventuellement
+ masquer les précédentes (warning ?)
+ *)
init_pack_mng_stabs (this: t) (pname: Ident.pack_name) (pm: pack_mng) = (
let pg = pm.pm_actual_src in
Verbose.printf ~level:3 " init symbol tables for pack %s\n"
(Ident.pack_name_to_string pname);
- (* ON COMMENCE PAR TRAITER LE PG_USES *)
+ (* ON COMMENCE PAR TRAITER LE PG_USES *)
let treat_uses (px:Ident.pack_name srcflagged) = (
let pname = px.it in
let lxm = px.src in
@@ -358,12 +359,12 @@ and
in
List.iter treat_uses pg.pg_uses ;
- (* PUIS LES DECLARATION LOCALES *)
- (* ... dans le body : *)
+ (* PUIS LES DECLARATION LOCALES *)
+ (* ... dans le body : *)
Hashtbl.iter (AstTabSymbol.add_type pm.pm_body_stab pname) pg.pg_body.pk_type_table;
Hashtbl.iter (AstTabSymbol.add_const pm.pm_body_stab pname) pg.pg_body.pk_const_table;
Hashtbl.iter (AstTabSymbol.add_node pm.pm_body_stab) pg.pg_body.pk_node_table;
- (* ... dans le provide : *)
+ (* ... dans le provide : *)
match pg.pg_provides with
| None -> ()
| Some spflg -> (
@@ -413,25 +414,25 @@ let (dump : t -> unit) =
p "*** « Syntax table dump:\n";
p " \t - Package or model list:\n\t\t";
- (* st_list : AstV6.pack_or_model list ; *)
+ (* st_list : AstV6.pack_or_model list ; *)
List.iter
(fun pm -> p (AstV6.pack_or_model_to_string pm); p "\n\t\t")
x.st_list ;
p "\n\t - Raw model table: ";
- (* st_raw_mod_tab : (Ident.t , model_info srcflagged) Hashtbl.t ; *)
+ (* st_raw_mod_tab : (Ident.t , model_info srcflagged) Hashtbl.t ; *)
Hashtbl.iter
(fun id _mi -> p ((Ident.to_string id) ^ " "))
x.st_raw_mod_tab;
p "\n\t - Raw Package table: ";
- (* st_raw_pack_tab : (Ident.pack_name , pack_info srcflagged) Hashtbl.t ; *)
+ (* st_raw_pack_tab : (Ident.pack_name , pack_info srcflagged) Hashtbl.t ; *)
Hashtbl.iter
(fun pn pi -> p ((Ident.pack_name_to_string pn) ^ " "))
x.st_raw_pack_tab;
p "\n\t - Package manager table: ";
- (* st_pack_mng_tab : (Ident.pack_name , pack_mng) Hashtbl.t; *)
+ (* st_pack_mng_tab : (Ident.pack_name , pack_mng) Hashtbl.t; *)
Hashtbl.iter
(fun pn pm -> p ((Ident.pack_name_to_string pn) ^ " "))
x.st_pack_mng_tab;
diff --git a/src/astTabSymbol.ml b/src/astTabSymbol.ml
index 46cf5277c38be46643a1f77f8c4a4e2c2bed5a26..397edd2332fec3a2cf40368c40057375fe28ac6e 100644
--- a/src/astTabSymbol.ml
+++ b/src/astTabSymbol.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 14:37) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 14:02) by Erwan Jahier> *)
(**
Sous-module pour AstTab
@@ -90,15 +90,15 @@ let add_type (this: t) pn (n: Ident.t) (tix: type_info srcflagged) = (
(* cas particulier des types enums *)
match tix.it with
EnumType (_, ecl) -> (
- let tname = Lxm.str tix.src in
- let treat_enum_const ec = (
- let te = Named_type_exp { Ident.id_pack = None; Ident.id_id = tname} in
- let tex = Lxm.flagit te tix.src in
- let ci = EnumConst (ec.it, tex) in
- add_const this pn ec.it (Lxm.flagit ci (ec.src));
- add_const this pn ec.it (Lxm.flagit ci (ec.src))
- ) in
- List.iter treat_enum_const ecl
+ let tname = Lxm.str tix.src in
+ let treat_enum_const ec = (
+ let te = Named_type_exp { Ident.id_pack = None; Ident.id_id = tname} in
+ let tex = Lxm.flagit te tix.src in
+ let ci = EnumConst (ec.it, tex) in
+ add_const this pn ec.it (Lxm.flagit ci (ec.src));
+ add_const this pn ec.it (Lxm.flagit ci (ec.src))
+ ) in
+ List.iter treat_enum_const ecl
)
| _ -> ()
)
diff --git a/src/astV6Dump.ml b/src/astV6Dump.ml
index 9b726c3d6d1cfd41f2fdad66c92b7f1bbe2c3e92..932820bcc744a6638f0fe94637ed7ca2fac9efa0 100644
--- a/src/astV6Dump.ml
+++ b/src/astV6Dump.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 07:59) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:51) by Erwan Jahier> *)
open Lxm
@@ -356,8 +356,11 @@ and dump_val_exp (os: Format.formatter) (x: val_exp) = (
match x with
| CallByPos ( {it=oper; src=lxm} , pars ) -> dump_by_pos_exp os oper pars
| CallByName ({it=oper; src=lxm},nm_pars) -> dump_by_name_exp os oper nm_pars
- | MERGE_n (id, _) -> (* finish me *)
+ | Merge_n (id, _) -> (* finish me *)
fprintf os "merge %s (...) " (Ident.to_string id.it)
+ | Merge_bool_n(id, t, f) ->
+ fprintf os "merge %s (true -> %a) (false -> %a)"
+ (Ident.to_string id.it) dump_val_exp t dump_val_exp f
)
and dump_val_exp_list (os : formatter) (xl: val_exp list) = (
match xl with
diff --git a/src/compile.ml b/src/compile.ml
index 9239672488cf82dd4e73c670a7eafadadd4353dd..2bb9f72267f22e5d75b0a38a6bdd1d1f02f077d3 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 23/01/2013 (at 16:44) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:28) by Erwan Jahier> *)
open Lxm
diff --git a/src/compile.mli b/src/compile.mli
index 20367b198e303dc1a7d9a4b1d2c0f7add8ee5fa5..96a7bc14388184fc1fb738677f62678ebdfea65d 100644
--- a/src/compile.mli
+++ b/src/compile.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:36) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:29) by Erwan Jahier> *)
(** Main bis *)
@@ -7,3 +7,4 @@
val doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t
+val if !Global.ec then L2lCheckLoops.doit zelic;
diff --git a/src/evalClock.ml b/src/evalClock.ml
index a53078c28b866ce2b1bbc1646e67836d54139a02..db41a92ac952af3d242cfa9c26762c180b6d0ae1 100644
--- a/src/evalClock.ml
+++ b/src/evalClock.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 08:39) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:52) by Erwan Jahier> *)
open AstPredef
@@ -210,16 +210,21 @@ and f_aux id_solver s ve =
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
)
| Merge(ce, cl) ->
- let _, (merge_clk : Lic.clock) =
+ let ce_id, (merge_clk : Lic.clock) =
var_info_eff_to_clock_eff (UglyStuff.var_info_of_ident id_solver ce.it ce.src)
in
-
-(* let ce_id, (merge_clk:Lic.clock) = match cel with [c] -> c | _ -> assert false in *)
- let check_case s (id,ve) =
- (* Check that ve is on id(ce) on merge_clk *)
- let id_clk : Ident.clk = (Ident.idref_of_long id.it, ce.it) in
+ let check_case s (c,ve) =
+ (* Check that ve is on c(ce) on merge_clk *)
+ let id_clk =
+ match c.it with
+ | Bool_const_eff true -> "True"
+ | Bool_const_eff false -> "False"
+ | Enum_const_eff (s,_) -> Ident.string_of_long2 s
+ | _ -> assert false
+ in
+ let id_clk : Ident.clk = (Ident.idref_of_string id_clk, ce.it) in
let exp_clk = [On(id_clk, merge_clk)] in
- let _ve,cel,s = f id.src id_solver s ve exp_clk in
+ let _ve,cel,s = f c.src id_solver s ve exp_clk in
s
in
let s = List.fold_left check_case s cl in
diff --git a/src/evalConst.ml b/src/evalConst.ml
index 6e82023198b79b446191426ef443ce2a900e34f1..ff4a0e3d306136cd726c6ade0797026105470ecf 100644
--- a/src/evalConst.ml
+++ b/src/evalConst.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 07:57) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:24) by Erwan Jahier> *)
open Printf
@@ -114,7 +114,7 @@ let make_struct_const
lxm ,
sprintf
"\n*** type error in struct %s, %s instead of %s"
- (Ident.string_of_long tnm)
+ (Ident.string_of_long2 tnm)
(Lic.string_of_type vt)
(Lic.string_of_type ft)
))
@@ -190,7 +190,8 @@ let rec f
with EvalConst_error msg ->
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
)
- | MERGE_n (_,_) ->
+ | Merge_n (_,_)
+ | Merge_bool_n (_,_,_) ->
finish_me "merge";
assert false
@@ -445,10 +446,10 @@ and eval_array_index
| [Int_const_eff i]
| [Abstract_const_eff(_,_, (Int_const_eff i), true)] -> i
| [Abstract_const_eff(id,_,_,false)] ->
- raise(EvalArray_error("The const " ^ (Ident.string_of_long id) ^
+ raise(EvalArray_error("The const " ^ (Ident.string_of_long2 id) ^
" is abstract"))
| [Extern_const_eff(id,_)] ->
- raise(EvalArray_error("The const " ^ (Ident.string_of_long id) ^
+ raise(EvalArray_error("The const " ^ (Ident.string_of_long2 id) ^
" is extern"))
| [x] -> raise(EvalArray_error(sprintf
"bad array index, int expected but get %s"
diff --git a/src/evalType.ml b/src/evalType.ml
index e1352e683cb836cdf6b77b9644c52f737dde9aca..99c94c29c16782b0d982b119440af6df8b057d10 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 01/02/2013 (at 08:36) by Erwan Jahier> *)
+(** Time-stamp: <modified the 01/02/2013 (at 14:29) by Erwan Jahier> *)
open AstPredef
@@ -319,16 +319,16 @@ and eval_by_name_type (id_solver: Lic.id_solver) (namop: Lic.by_name_op) (lxm:
| _ -> raise (Compile_error(lxm, "type error: a structure is expected"))
and (eval_merge : Lic.id_solver -> Ident.t -> Lxm.t ->
- (Ident.long Lxm.srcflagged * Lic.val_exp) list -> Lic.val_exp_core * Lic.type_ list) =
+ (Lic.const Lxm.srcflagged * Lic.val_exp) list -> Lic.val_exp_core * Lic.type_ list) =
fun id_solver clk lxm nargs ->
let tclk = (UglyStuff.var_info_of_ident id_solver clk lxm).var_type_eff in
let nargs,tl_opt =
List.fold_left
- (fun (acc,tl_opt) (id,ve) ->
+ (fun (acc,tl_opt) (c,ve) ->
(* check that id is of type tclk *)
let id_type =
- let c = id_solver.id2const (Ident.idref_of_long id.it) id.src in
- type_of_const c
+(* let c = id_solver.id2const (Ident.idref_of_long id.it) id.src in *)
+ type_of_const c.it
in
if id_type <> tclk then (
let msg = "type error in a merge branch: " ^
@@ -349,7 +349,7 @@ and (eval_merge : Lic.id_solver -> Ident.t -> Lxm.t ->
in
raise (Compile_error(lxm, "type error: "^msg))
in
- (id,ve)::acc, tl_opt
+ (c,ve)::acc, tl_opt
)
([],None)
nargs
diff --git a/src/ident.ml b/src/ident.ml
index 11018b251547f2fa4084955a586002936e2c5ec3..b40a3c8f03e474a07875375e26b001f67dac0989 100644
--- a/src/ident.ml
+++ b/src/ident.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 07/01/2013 (at 14:09) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:32) by Erwan Jahier> *)
(* J'ai appele ca symbol (mais ca remplace le ident) :
c'est juste une couche qui garantit l'unicite en memoire
@@ -84,7 +84,7 @@ let (no_pack_string_of_long : long -> string) =
id
let (long_to_string : long -> string) =
- string_of_long
+ string_of_long2
let (make_long : pack_name -> t -> long) =
fun pn id -> (pn,id)
diff --git a/src/l2lExpandArrays.ml b/src/l2lExpandArrays.ml
index 8839ada63e96f18c08f22faa06b44952b7d855c1..d4900356dd6469f91d3ae204eb2ae85f3aba76b2 100644
--- a/src/l2lExpandArrays.ml
+++ b/src/l2lExpandArrays.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 31/01/2013 (at 09:53) by Erwan Jahier> *)
+(** Time-stamp: <modified the 01/02/2013 (at 17:25) by Erwan Jahier> *)
(* Replace structures and arrays by as many variables as necessary.
Since structures can be recursive, it migth be a lot of new variables...
@@ -315,7 +315,7 @@ and (var_trees_of_val_exp :
with _ ->
let msg =
"\n*** during Array expansion: '"^
- (Ident.string_of_long idl)^
+ (Ident.string_of_long2 idl)^
"': Unknown constant.\n"^
"*** Current constants are: "^
(LicPrg.fold_consts
diff --git a/src/lic.ml b/src/lic.ml
index d978ff3d8ab3fee3cef674040dd135a2ee832a27..b841c8af1a2a58e2bd54fe9920cf369daad9695f 100644
--- a/src/lic.ml
+++ b/src/lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 08:22) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:57) by Erwan Jahier> *)
(** Define the Data Structure representing Compiled programs. *)
@@ -190,7 +190,7 @@ and val_exp_core =
| CallByPosLic of (by_pos_op srcflagged * operands)
| CallByNameLic of
(by_name_op srcflagged * (Ident.t srcflagged * val_exp) list)
- | Merge of Ident.t srcflagged * (Ident.long srcflagged * val_exp) list
+ | Merge of Ident.t srcflagged * (const srcflagged * val_exp) list
and operands = OperLic of val_exp list
@@ -260,9 +260,6 @@ and const =
Une constante ou une variable
=> item de la table des symboles de valeurs
----------------------------------------------------------------------*)
-(* and val = *)
-(* ConstLic of const *)
-(* | VarLic of var_info *)
(*---------------------------------------------------------------------
Type: var_info
-----------------------------------------------------------------------
@@ -648,11 +645,18 @@ let (clock_of_left: left -> clock) =
fun left ->
snd (var_info_of_left left).var_clock_eff
+
(* utils N.B peut etre different de LicDump ! *)
let string_of_ident x =
if !Global.no_prefix
+(* XXX Ce genre de test n'a VRAIMENT rien a faire ici. Dans licDump, ok, mais
+ pas ici.
+
+ Bon, ca oblige à dupliquer un peu le code, mais tant pis !
+ *)
then Ident.no_pack_string_of_long x
- else Ident.string_of_long x
+
+ else Ident.string_of_long2 x
let rec string_of_type = function
| Bool_type_eff -> "bool"
diff --git a/src/licDump.ml b/src/licDump.ml
index 6d8282ccc34516466ff3d3a82b3716b70bf42db7..5cec0adfdf9ee03c85b47e33ad36bbe5430f764c 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 08:27) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 16:18) by Erwan Jahier> *)
open Errors
open Printf
@@ -436,11 +436,17 @@ and string_of_val_exp_eff_core ve_core =
(* ICI : on pourrait afficher en commentaire l'éventuel type_matches ? *)
(string_of_by_pos_op_eff by_pos_op_eff vel)
+ | Merge (ve, [({it=Bool_const_eff true}, ct); ({it=Bool_const_eff false}, cf)])
+ | Merge (ve, [({it=Bool_const_eff false}, cf); ({it=Bool_const_eff true}, ct)]) -> (
+ "merge(" ^ (Ident.to_string ve.it) ^ ", " ^
+ (string_of_val_exp_eff ct) ^ ", "^ (string_of_val_exp_eff cf) ^")"
+ )
| Merge (ve, cl) -> (
"merge " ^ (Ident.to_string ve.it) ^ " " ^
(String.concat " "
(List.map
- (fun (id,ve) -> "| "^(dump_long id.it) ^ " => " ^ (string_of_val_exp_eff ve)^" ")
+ (fun (id,ve) -> "( "^(string_of_const_eff id.it) ^ " -> " ^
+ (string_of_val_exp_eff ve)^" )")
cl
)
)
diff --git a/src/licTab.ml b/src/licTab.ml
index 56690ff268ec489e66e9dfca6c5879c653c108dd..0ca80a01ca895d53b75a50db411496a378684c10 100644
--- a/src/licTab.ml
+++ b/src/licTab.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 31/01/2013 (at 09:40) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:25) by Erwan Jahier> *)
open Lxm
@@ -184,7 +184,7 @@ let x_check
let x_def = match find_x x_pack_symbols xn lxm with
| AstTabSymbol.Local x_def -> x_def
| AstTabSymbol.Imported (lid,_) ->
- print_string ("*** " ^ (Ident.string_of_long lid) ^ "???\n" ^
+ print_string ("*** " ^ (Ident.string_of_long2 lid) ^ "???\n" ^
(Lxm.details lxm));
assert false (* should not occur *)
in
@@ -664,7 +664,7 @@ and (node_check_interface_do: t -> Lic.node_key -> Lxm.t ->
if t1 = t2 or t1 is abstract and and t2.
*)
let msg_prefix =
- ("provided node for " ^ (Ident.string_of_long (fst nk)) ^
+ ("provided node for " ^ (Ident.string_of_long2 (fst nk)) ^
" is not compatible with its implementation: ")
in
let str_of_var = Lic.string_of_var_info in
@@ -902,7 +902,8 @@ and (node_check_interface_do: t -> Lic.node_key -> Lxm.t ->
ce
) with Not_found -> (
(* not a local constant -> search in global env *)
- Verbose.printf ~level:3 " * %s not a local const, should be global ?" (Ident.string_of_idref idrf);
+ Verbose.printf ~level:3
+ " * %s not a local const, should be global ?" (Ident.string_of_idref idrf);
let ce = node_id_solver.id2const idrf lxm in
Verbose.printf ~level:3 " YES -> %s\n" (LicDump.string_of_const_eff ce);
ce
@@ -1245,8 +1246,8 @@ and (node_check_interface_do: t -> Lic.node_key -> Lxm.t ->
this nk lxm
) with
Recursion_error (n, stack) ->
- let msg = "Recursion loop detected in node " ^ (Ident.string_of_long (fst nk)) in
- let msg = msg ^ "\n*** "^ (Ident.string_of_long n) ^ " depends on itself\n "
+ let msg = "Recursion loop detected in node " ^ (Ident.string_of_long2 (fst nk)) in
+ let msg = msg ^ "\n*** "^ (Ident.string_of_long2 n) ^ " depends on itself\n "
^ (String.concat "\n*****" stack) in
raise (Compile_error (lxm, msg))
@@ -1279,11 +1280,11 @@ let compile_all_item this label x_check_interface string_of_x_key
| AstTabSymbol.Imported(item_def,_) -> ()
(* Printf.printf "\t\t%s %s = %s (imported)\n" *)
-(* label (string_of_x_key (to_key id)) (Ident.string_of_long item_def) *)
+(* label (string_of_x_key (to_key id)) (Ident.string_of_long2 item_def) *)
let compile_all_types pack_name this =
- compile_all_item this "type" type_check_interface Ident.string_of_long
+ compile_all_item this "type" type_check_interface Ident.string_of_long2
Lic.string_of_type (fun id -> Ident.make_long pack_name id)
let compile_all_constants pack_name this =
@@ -1364,7 +1365,7 @@ let compile_all (this:t) : t =
this
with
Recursion_error (n, stack) ->
- let msg = "Recursion loop detected in node " ^ (Ident.string_of_long n) in
+ let msg = "Recursion loop detected in node " ^ (Ident.string_of_long2 n) in
let msg = msg ^ "\n*****" ^ (String.concat "\n*****" stack) in
raise (Compile_error (Lxm.dummy "", msg))
diff --git a/src/parser.mly b/src/parser.mly
index 48c1afb484a66402d648415578bfe0eb4697ae94..abddbd20e39b9c93e39992b39c809c86ee46e866 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -828,7 +828,7 @@ Expression:
;
MergeCaseList:
- MergeCase
+ | MergeCase
{ [$1] }
| MergeCaseList MergeCase
{ $2::$1 }
@@ -836,7 +836,11 @@ MergeCaseList:
MergeCase:
| TK_OPEN_PAR IdentRef TK_ARROW Expression TK_CLOSE_PAR
- { ($2,$4) }
+ { (Idref $2.it,$2.src,$4) }
+ | TK_OPEN_PAR TK_TRUE TK_ARROW Expression TK_CLOSE_PAR
+ { (Bool true, $2,$4) }
+ | TK_OPEN_PAR TK_FALSE TK_ARROW Expression TK_CLOSE_PAR
+ { (Bool false, $2,$4) }
;
ClockExpr:
@@ -949,7 +953,8 @@ StaticArg:
| IDENT_n idref -> {src=op.src ; it = StaticArgIdent idref }
| _ -> {src=op.src ; it= StaticArgConst $1}
)
- | MERGE_n _
+ | Merge_bool_n _
+ | Merge_n _
| CallByName _ ->
print_string "*** unexpected static argument\n";
assert false
@@ -1005,7 +1010,8 @@ ByNameStaticArg:
| IDENT_n idref -> {src=op.src ; it = StaticArgIdent idref }
| _ -> {src=op.src ; it= StaticArgConst $3}
)
- | MERGE_n _
+ | Merge_bool_n _
+ | Merge_n _
| CallByName _ ->
print_string "*** unexpected static argument\n";
assert false
diff --git a/src/parserUtils.ml b/src/parserUtils.ml
index b7be8ada584d741fd31d1395f1933c1ef061bdd3..b230a3852f95c60eee6aa44be639d6690ddd8c12 100644
--- a/src/parserUtils.ml
+++ b/src/parserUtils.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/02/2013 (at 08:05) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:50) by Erwan Jahier> *)
(** *)
@@ -128,10 +128,36 @@ let (lexeme_to_pack_name_flagged:Lxm.t -> Ident.pack_name Lxm.srcflagged) =
fun x -> {it = (Ident.pack_name_of_string (Lxm.str x)); src = x }
+let (make_merge_bool_op : Lxm.t -> val_exp -> val_exp -> val_exp) =
+ fun enum_clk vet vef ->
+ Merge_bool_n(lexeme_to_ident_flagged enum_clk, vet, vef)
+
+type bool_or_idref = Bool of bool | Idref of Ident.idref
(** Utilitaries to build [val_exp] *)
-let make_merge_op (enum_clk:Lxm.t) (l:(Ident.idref srcflagged * val_exp) list) =
+let make_merge_op (enum_clk:Lxm.t) (l:(bool_or_idref * Lxm.t * val_exp) list) =
+ match l with
+ | [(Bool true ,_,vet); (Bool false,_,vef)]
+ | [(Bool false,_,vef); (Bool true ,_,vet)] ->
+ make_merge_bool_op enum_clk vet vef
+ | _ ->
+ let l = List.map
+ (fun (b_or_idref,lxm,ve) ->
+ match b_or_idref with
+ | Idref idref -> flagit idref lxm, ve
+ | Bool true
+ | Bool false ->
+ raise (
+ Errors.Compile_error (enum_clk, "The merge mixes booleans and enums"))
+ )
+ l
+ in
+ Merge_n(lexeme_to_ident_flagged enum_clk, l)
+
+let save_make_merge_op (enum_clk:Lxm.t) (l:(Ident.idref srcflagged * val_exp) list) =
let l = List.map (fun (idref,ve) -> idref,ve) l in
- MERGE_n(lexeme_to_ident_flagged enum_clk, l)
+ Merge_n(lexeme_to_ident_flagged enum_clk, l)
+
+
let make_predef_posop lxm op =
let op = flagit op lxm in
@@ -496,4 +522,4 @@ let (make_ident : Lxm.t -> pragma list -> Lxm.t) =
let (make_clock_exp : string -> Lxm.t -> clock_exp) =
fun str v_lxm ->
- NamedClock(Lxm.flagit (Ident.idref_of_string str, (Lxm.id v_lxm)) v_lxm)
+ NamedClock( Lxm.flagit (Ident.idref_of_string str, (Lxm.id v_lxm)) v_lxm)
diff --git a/src/unifyType.ml b/src/unifyType.ml
index 0efcb4f50d0a2b195db6d092dc9930036d745de0..ccc080ad250634eaa1d06ae6bbf7d64cc0cb728c 100644
--- a/src/unifyType.ml
+++ b/src/unifyType.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 14/01/2013 (at 18:22) by Erwan Jahier> *)
+(* Time-stamp: <modified the 01/02/2013 (at 17:25) by Erwan Jahier> *)
(*
12/07. Premier pas vers une méthode un peu plus standard :
@@ -261,7 +261,7 @@ let (profile_is_compatible: node_key -> Lxm.t -> Lic.type_ list * Lic.type_ list
| Abstract_type_eff(name, _) -> (TypeVar Any)
| t -> t
in
- let msg_prefix = ("provided node for " ^ (Ident.string_of_long (fst nk)) ^
+ let msg_prefix = ("provided node for " ^ (Ident.string_of_long2 (fst nk)) ^
" is not compatible with its implementation: ")
in
let apply_subst s t = try List.assoc t s with Not_found -> t in
diff --git a/test/lus2lic.log.ref b/test/lus2lic.log.ref
index 55a8952e9f5951489395b3a4e573ddf231080ce3..31bfbd55638a38365abab8770d6ca580b9dfc2ea 100644
--- a/test/lus2lic.log.ref
+++ b/test/lus2lic.log.ref
@@ -1,4 +1,4 @@
-Test Run By jahier on Fri Feb 1 09:58:49 2013
+Test Run By jahier on Fri Feb 1 17:47:52 2013
Native configuration is i686-pc-linux-gnu
=== lus2lic tests ===
@@ -1428,7 +1428,7 @@ PASS: ./lus2lic {-o /tmp/merge.lic should_work/merge.lus}
spawn ./lus2lic -ec -o /tmp/merge.ec should_work/merge.lus
PASS: ./lus2lic {-ec -o /tmp/merge.ec should_work/merge.lus}
spawn ./ec2c -o /tmp/merge.c /tmp/merge.ec
-syntax error - at line 13
+syntax error - at line 14
syntax errors...
FAIL: Try ec2c on the result: ./ec2c {-o /tmp/merge.c /tmp/merge.ec}
spawn ./lus2lic -o /tmp/decl.lic should_work/decl.lus
@@ -1538,6 +1538,11 @@ spawn ./lus2lic -o /tmp/Gyro-2.lic should_fail/type/Gyro-2.lus
*** syntax error
XFAIL: Test bad programs (type): lus2lic {-o /tmp/Gyro-2.lic should_fail/type/Gyro-2.lus}
+spawn ./lus2lic -o /tmp/merge_bad.lic should_fail/type/merge_bad.lus
+*** Error in file "/home/jahier/lus2lic/test/should_fail/type/merge_bad.lus", line 7, col 14 to 16, token 'clk':
+*** The merge mixes booleans and enums
+
+XFAIL: Test bad programs (type): lus2lic {-o /tmp/merge_bad.lic should_fail/type/merge_bad.lus}
spawn ./lus2lic -o /tmp/merge_bad_clk.lic should_fail/type/merge_bad_clk.lus
*** Error in file "/home/jahier/lus2lic/test/should_fail/type/merge_bad_clk.lus", line 9, col 9 to 12, token 'Pile':
***
@@ -1708,7 +1713,7 @@ spawn ./lus2lic -o /tmp/m.lic should_fail/semantics/m.lus
*** syntax error
XFAIL: Test bad programs (semantics): lus2lic {-o /tmp/m.lic should_fail/semantics/m.lus}
-testcase ./lus2lic.tests/non-reg.exp completed in 53 seconds
+testcase ./lus2lic.tests/non-reg.exp completed in 54 seconds
Running ./lus2lic.tests/progression.exp ...
spawn ./lus2lic -o /tmp/when_enum.out should_work/broken/when_enum.lus
*** Error in file "/home/jahier/lus2lic/test/should_work/broken/when_enum.lus", line 10, col 11 to 14, token 'toto':
@@ -1808,6 +1813,6 @@ testcase ./lus2lic.tests/progression.exp completed in 0 seconds
# of expected passes 734
# of unexpected failures 9
# of unexpected successes 11
-# of expected failures 36
+# of expected failures 37
# of unresolved testcases 2
-runtest completed at Fri Feb 1 09:59:42 2013
+runtest completed at Fri Feb 1 17:48:46 2013
diff --git a/test/lus2lic.sum b/test/lus2lic.sum
index 80f835954d5826afec94301ddf36a13826f75011..fa0d3fd6562ac95352ab37dbbd29695094fa2ca6 100644
--- a/test/lus2lic.sum
+++ b/test/lus2lic.sum
@@ -1,4 +1,4 @@
-Test Run By jahier on Fri Feb 1 09:58:49 2013
+Test Run By jahier on Fri Feb 1 17:52:18 2013
Native configuration is i686-pc-linux-gnu
=== lus2lic tests ===
@@ -752,6 +752,7 @@ XFAIL: Test bad programs (type): lus2lic {-o /tmp/packages.lic should_fail/type/
XFAIL: Test bad programs (type): lus2lic {-o /tmp/packages2.lic should_fail/type/packages2.lus}
XFAIL: Test bad programs (type): lus2lic {-o /tmp/Gyro.lic should_fail/type/Gyro.lus}
XFAIL: Test bad programs (type): lus2lic {-o /tmp/Gyro-2.lic should_fail/type/Gyro-2.lus}
+XFAIL: Test bad programs (type): lus2lic {-o /tmp/merge_bad.lic should_fail/type/merge_bad.lus}
XFAIL: Test bad programs (type): lus2lic {-o /tmp/merge_bad_clk.lic should_fail/type/merge_bad_clk.lus}
XFAIL: Test bad programs (type): lus2lic {-o /tmp/parametric_node4.lic should_fail/type/parametric_node4.lus}
XPASS: Test bad programs (type): lus2lic {-o /tmp/merge_not_exhaustive.lic should_fail/type/merge_not_exhaustive.lus}
@@ -807,5 +808,5 @@ XPASS: Test bad programs (semantics): lus2lic {-o /tmp/bug.lic should_fail/seman
# of expected passes 734
# of unexpected failures 9
# of unexpected successes 11
-# of expected failures 36
+# of expected failures 37
# of unresolved testcases 2
diff --git a/test/should_fail/type/merge_bad.lus b/test/should_fail/type/merge_bad.lus
new file mode 100644
index 0000000000000000000000000000000000000000..a66bd162f8ead58bfe1125aa412c3a208b5f15c9
--- /dev/null
+++ b/test/should_fail/type/merge_bad.lus
@@ -0,0 +1,8 @@
+
+type mybool = enum { True, False };
+
+
+node merge_bool_ter(clk : bool ; i1 : int when clk ; i2 : int when not clk) returns (y: int);
+let
+ y = merge clk (false-> i2) (True -> i1) ;
+tel
diff --git a/test/should_work/merge.lus b/test/should_work/merge.lus
index b3519916a1adbd63ef565370c8ccbb220361c050..1bfb2bbe1e8389c7208ff3a5bd7a4b4398d40e7b 100644
--- a/test/should_work/merge.lus
+++ b/test/should_work/merge.lus
@@ -10,3 +10,14 @@ let
( Face -> i2)
( Tranche -> i3);
tel
+
+node merge_bool_alt(clk : bool ; i1 : int when clk ; i2 : int when not clk) returns (y: int);
+let
+ y = merge clk (true -> i1) (false-> i2);
+tel
+
+node merge_bool_ter(clk : bool ; i1 : int when clk ; i2 : int when not clk) returns (y: int);
+let
+ y = merge clk (false-> i2) (true -> i1) ;
+tel
+
diff --git a/todo.org b/todo.org
index ecc1c393877d17e0004e727f581484d8699f01f0..ffeab9b28a263654774480a506ceb0d58c6203d7 100644
--- a/todo.org
+++ b/todo.org
@@ -112,9 +112,14 @@ y virer !!
- State "TODO" from "" [2012-10-26 Fri 14:59]
** TODO const_to_val_eff n'a vraiment rien à faire dans UnifyClock !!!
+
- State "TODO" from "" [2013-01-29 Tue 14:26]
file:src/unifyClock.ml::271
+** TODO aucune fonction dans Lic.*_to_string ne devrait dependre des options de compil
+ - State "TODO" from "" [2013-02-01 Fri 17:54]
+cf le XXX file:src/lic.ml::655
+
* Languages issues
** TODO Verifier les boucles combinatoires meme quand on ne genere pas de ec
- State "TODO" from "STARTED" [2013-01-29 Tue 09:49]
diff --git a/utils/lustre.el b/utils/lustre.el
index 5fcc2012e3b05a2f8f953c2245eb964454351b8c..79ade4aaa5017d216180736e967f1423f7ea5e1b 100644
--- a/utils/lustre.el
+++ b/utils/lustre.el
@@ -104,9 +104,6 @@
"Keymap for lustre major mode.")
(unless lustre-mode-map
(setq lustre-mode-map (make-sparse-keymap))
- ;; NB: strip those annoying electric keys.
- ;; (define-key lustre-mode-map "," 'electric-lustre-special-char)
- ;; (define-key lustre-mode-map ":" 'electric-lustre-special-char)
(define-key lustre-mode-map "\C-c\C-c" 'lustre-compil)
(define-key lustre-mode-map "\r" 'electric-lustre-end-of-line)
;; (define-key lustre-mode-map "\t" 'electric-lustre-tab)
@@ -285,11 +282,6 @@
result))
-(defun electric-lustre-special-char ()
- "Insert a space after ',' or ':' ."
- (interactive)
- (insert last-command-char)
- (insert " "))
(defun electric-lustre-end-of-line ()
"Insert a newline."