diff --git a/Makefile b/Makefile
index 5dedb078e6476dca87bde5d4b5d23680719b60ea..923ed399e3f43038e2dda76815400ba1632ce951 100644
--- a/Makefile
+++ b/Makefile
@@ -48,6 +48,8 @@ SOC_SOURCES = \
$(OBJDIR)/lic2soc.ml \
$(OBJDIR)/socExecValue.mli \
$(OBJDIR)/socExecValue.ml \
+ $(OBJDIR)/rif_base.mli \
+ $(OBJDIR)/rif_base.ml \
$(OBJDIR)/socExecEvalPredef.mli \
$(OBJDIR)/socExecEvalPredef.ml \
$(OBJDIR)/socExec.mli \
@@ -57,6 +59,8 @@ SOC_SOURCES = \
SOURCES = \
$(OBJDIR)/version.ml \
$(OBJDIR)/verbose.mli \
+ $(OBJDIR)/genlex.mli \
+ $(OBJDIR)/genlex.ml \
$(OBJDIR)/verbose.ml \
$(OBJDIR)/filenameExtras.mli \
$(OBJDIR)/filenameExtras.ml \
diff --git a/src/actionsDeps.ml b/src/actionsDeps.ml
index 316877e259309b0a398d7f0d5998b33bdab40a05..0bdb5c4e2a5dc14d0b829a479c4a604cbe3f8133 100644
--- a/src/actionsDeps.ml
+++ b/src/actionsDeps.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 21/02/2013 (at 11:12) by Erwan Jahier> *)
+(** Time-stamp: <modified the 12/03/2013 (at 14:19) by Erwan Jahier> *)
(* exported *)
diff --git a/src/actionsDeps.mli b/src/actionsDeps.mli
index 696133601a8ece664d8bd13cb0ed02c3500d7ba2..85b73951adc2a22e836e4ad780db4253724c63ed 100644
--- a/src/actionsDeps.mli
+++ b/src/actionsDeps.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 21/02/2013 (at 11:11) by Erwan Jahier> *)
+(** Time-stamp: <modified the 12/03/2013 (at 14:18) by Erwan Jahier> *)
(** Compute dependencies between actions *)
@@ -46,3 +46,4 @@ val generate_deps_from_step_policy: Soc.precedence list -> (string * action) lis
(** Returns the list of actions that depends on the action in argument. *)
val find_deps: t -> action -> action list
+
diff --git a/src/compile.ml b/src/compile.ml
index 55efd6d937dd2b68cdc77c9dbcbe9a6f55b359be..a8489937ffbbc5a38fc88169830f8cf3110fbafa 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 07/03/2013 (at 14:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/03/2013 (at 16:33) by Erwan Jahier> *)
open Lxm
open Errors
@@ -69,15 +69,5 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
if !Global.ec then L2lCheckLoops.doit zelic;
L2lCheckOutputs.doit zelic;
- (* XXX just to see if it compiles *)
- (* SocUtils.output true "xxx" zesoc; *)
-
- if !Global.exec then
- (match main_node with
- | None -> ()
- | Some main_node ->
- let msk, zesoc = Lic2soc.f zelic (Lic.node_key_of_idref main_node) in
- SocExec.f zesoc msk
- );
zelic
diff --git a/src/global.ml b/src/global.ml
index edb906818469078c9b39a65ee8469a52ebafb0d5..2896153784645567049b3db97f3025987ee9424d 100644
--- a/src/global.ml
+++ b/src/global.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 05/03/2013 (at 16:39) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/03/2013 (at 17:17) by Erwan Jahier> *)
(** Global variables for handling command-line options. *)
diff --git a/src/lic.ml b/src/lic.ml
index df369cd41e5c5dc5a0a4e554467d64b14b386f51..1ae1941b431731e7ec3074a3cd16828f3e47a117 100644
--- a/src/lic.ml
+++ b/src/lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 26/02/2013 (at 18:58) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 15:44) by Erwan Jahier> *)
(** Define the Data Structure representing Compiled programs. *)
diff --git a/src/lic2soc.ml b/src/lic2soc.ml
index b1611586e7a475209d4ff73432d8c0020a467641..8ca3833abb0ef25cf43af795e8d55666876c674b 100644
--- a/src/lic2soc.ml
+++ b/src/lic2soc.ml
@@ -1,8 +1,10 @@
-(** Time-stamp: <modified the 11/03/2013 (at 09:19) by Erwan Jahier> *)
+(** Time-stamp: <modified the 19/03/2013 (at 10:32) by Erwan Jahier> *)
open Lxm
open Lic
+let dbg = Some(Verbose.get_flag "exec")
+
type action = ActionsDeps.action
(* Raised when a soc that haven't been translated yet is used in
@@ -89,14 +91,17 @@ let (slice_info_to_index_list : Lic.slice_info -> int list) =
in
aux f
-(* if val_exp is a leaf (i.e., a constant) *)
+(* Returns Some(thing) if val_exp is a leaf (a var or a constant)
+
+XXX c'est pas tres clair le role de cette fonction. Expliquer !
+*)
let rec get_leaf: (LicPrg.t -> Lic.val_exp -> Soc.var_expr list option) =
fun licprg val_exp ->
let v = val_exp.Lic.ve_core in
let type_ = val_exp.Lic.ve_typ in
match v with
- | Lic.CallByNameLic(by_name_op_flg,fl) -> assert false
- | Lic.Merge(c_flg, cl) -> assert false
+ | Lic.CallByNameLic(by_name_op_flg,fl) -> None
+ | Lic.Merge(c_flg, cl) -> None
| Lic.CallByPosLic (by_pos_op_flg, val_exp_list) -> (
match by_pos_op_flg.it with
| Lic.VAR_REF name ->
@@ -168,13 +173,13 @@ let rec get_leaf: (LicPrg.t -> Lic.val_exp -> Soc.var_expr list option) =
| Lic.PREDEF_CALL _
| Lic.CALL _
| Lic.PRE
+ | Lic.ARRAY
+ | Lic.HAT _
| Lic.ARROW
| Lic.FBY
| Lic.CURRENT
| Lic.WHEN(_)
| Lic.CONCAT
- | Lic.HAT _
- | Lic.ARRAY
-> None
)
(** Traduction d'une partie gauche d'équation en filtre d'accès soc. *)
@@ -220,8 +225,7 @@ let rec (gao_of_action: action -> Soc.gao) =
in
unpack_clock ck
-(* Construit une méthode à partir des informations données *)
-let build_meth: Lxm.t -> string -> Lic.node_exp -> Soc.var list ->
+let build_step: Lxm.t -> string -> Lic.node_exp -> Soc.var list ->
action list -> Soc.step_method =
fun lxm name node locals actions ->
(* Converti les entrées/sorties d'un noeud en index
@@ -255,14 +259,20 @@ let (soc_key_of_node_exp : Lic.node_exp -> Soc.key) =
assert (sargs=[]);
Ident.string_of_long2 id, List.map snd (svi@svo), None
-
+(* XXX duplicated code with get_leaf *)
let (val_exp_to_filter: LicPrg.t -> Lic.val_exp -> Soc.var_expr) =
fun licprg val_exp ->
let v = val_exp.Lic.ve_core in
let type_ = val_exp.Lic.ve_typ in
match v with
- | CallByNameLic(by_name_op_flg,fl) -> assert false
- | Merge(c_flg, cl) -> assert false
+ | CallByNameLic(by_name_op_flg,fl) ->
+ print_string "Struct not yet supported, sorry\n";
+ flush stdout;
+ assert false
+ | Merge(c_flg, cl) ->
+ print_string "Merge not yet supported, sorry\n";
+ flush stdout;
+ assert false
| CallByPosLic (by_pos_op_flg, val_exp_list) -> (
match by_pos_op_flg.it with
| VAR_REF name ->
@@ -321,20 +331,24 @@ let (val_exp_to_filter: LicPrg.t -> Lic.val_exp -> Soc.var_expr) =
)
(*********************************************************************************)
-type memory = Soc.instance * action list (* mémoire + initialisation *)
+(* type instance_init = Soc.instance * action list (* instance + son initialisation *) *)
(** Créé une opération à partir d'un nom de méthode d'un composant. *)
-let soc_meth_to_operation:
- Soc.t -> string -> memory option -> Soc.atomic_operation =
- fun comp func_name -> function
- | None -> Soc.Procedure comp.Soc.key
- | Some (i,_) -> Soc.Method(i)
-
-(* Créé une action concernant un appel de procédure ou de méthode. *)
-let (action_of_method: Lxm.t -> Soc.t -> Lic.clock -> Soc.var_expr list ->
- Soc.var_expr list -> memory option -> Soc.step_method -> action) =
- fun lxm c clk il ol mem m ->
- let nth i l =
+let soc_step_to_operation:
+ Soc.ident -> Soc.t -> Soc.instance option -> Soc.atomic_operation =
+ fun name comp -> function
+ | None -> Soc.Procedure (comp.Soc.key)
+ | Some (i) -> Soc.Method(i,name)
+
+let (action_of_step: Lxm.t -> Soc.t -> Lic.clock -> Soc.var_expr list ->
+ Soc.var_expr list -> Soc.instance option -> Soc.step_method -> action) =
+ fun lxm c clk il ol mem step ->
+ let local_nth i l =
+ if i < 0 then
+ (* to handle the particular case of arrow. XXX just a crutch to make it works *)
+ let mem_name = SocPredef.get_mem_name c.Soc.key Soc.Bool in
+ Soc.Var(mem_name, Soc.Bool)
+ else
try List.nth l i
with _ ->
print_string (
@@ -343,14 +357,14 @@ let (action_of_method: Lxm.t -> Soc.t -> Lic.clock -> Soc.var_expr list ->
flush stdout;
assert false
in
- let inputs = List.map (fun i -> nth i il) m.Soc.idx_ins in
- let outputs = List.map (fun i -> nth i ol) m.Soc.idx_outs in
- let call_action = soc_meth_to_operation c m.Soc.name mem in
- (clk, inputs, outputs, call_action, lxm)
+ let inputs = List.map (fun i -> local_nth i il) step.Soc.idx_ins in
+ let outputs = List.map (fun i -> local_nth i ol) step.Soc.idx_outs in
+ let call_action = soc_step_to_operation step.Soc.name c mem in
+ (clk, inputs, outputs, call_action, step.Soc.lxm)
(** Créé un nouveau nom pour une instance. *)
-let create_new_instance_name: (ctx -> ctx * string) = fun ctx ->
- let prefix = "m" in
+let create_new_instance_name: (Soc.key -> ctx -> ctx * string) = fun (soc_name,_,_) ctx ->
+ let prefix = soc_name in
let suffix = "" in
let make id = Format.sprintf "%s%d%s" prefix id suffix in
let new_ctx = {ctx with last_mem = ctx.last_mem + 1 } in
@@ -358,28 +372,29 @@ let create_new_instance_name: (ctx -> ctx * string) = fun ctx ->
(** Créé une nouvelle instance pour être utilisée dans un composant.
- Pendant la traduction d'un opérateur, on s'apercoit que cet opérateur
- dispose d'une (ou plusieur) mémoire.
- Il faut donc qu'on créé une mémoire représentant ce composant (issue de la
- traduction de cet opérateur), afin de garder son état dans le composant
- résultant de ce noeud. *)
+ Pendant la traduction d'un opérateur, on s'apercoit que cet
+ opérateur dispose d'une (ou plusieur) mémoire. Il faut donc
+ qu'on créé une instance de ce composant. *)
let create_instance_from_soc: (ctx -> Soc.t -> ctx * Soc.instance) =
fun ctx c ->
- let ctx, mem_name = create_new_instance_name ctx in
- ctx, (mem_name, c.Soc.key)
+ let ctx, inst_name = create_new_instance_name c.Soc.key ctx in
+ ctx, (inst_name, c.Soc.key)
-let (make_memory : Lxm.t -> Lic.clock -> ctx -> Soc.t ->
- Soc.var_expr list -> Soc.var_expr list -> ctx * memory option) =
- fun lxm clk ctx soc inputs lpl ->
+(* if the soc has memories, do create an instance *)
+let (make_instance :
+ Lxm.t -> Lic.clock -> ctx -> Soc.t -> ctx * Soc.instance option) =
+ fun lxm clk ctx soc ->
match soc.Soc.instances with
- | [] -> ctx, None
+ | [] -> (
+ match soc.Soc.have_mem with
+ | None -> ctx, None
+ | Some _ ->
+ let ctx, m = create_instance_from_soc ctx soc in
+ ctx, Some(m)
+ )
| _ ->
let ctx, m = create_instance_from_soc ctx soc in
- let init_actions = match soc.Soc.init with
- | Some i -> [action_of_method lxm soc clk inputs lpl (Some (m, [])) i]
- | None -> assert false
- in
- ctx, Some(m, init_actions)
+ ctx, Some(m)
(*********************************************************************************)
(** Transforme une expression en action(s), et retourne la liste des variables
@@ -387,24 +402,24 @@ let (make_memory : Lxm.t -> Lic.clock -> ctx -> Soc.t ->
Ces nouvelles variables serviront d'entrées pour l'expression parente.
*)
-type e2a_acc = ctx * action list * Soc.var_expr list * memory list * ActionsDeps.t
+type e2a_acc = ctx * action list * Soc.var_expr list * Soc.instance list * ActionsDeps.t
(* Béquille en attendant mieux *)
let by_pos_op_to_soc_ident = function
- | PREDEF_CALL AstPredef.TRUE_n -> assert false
+ | PREDEF_CALL AstPredef.TRUE_n -> assert false (* catched by get_leaf *)
| PREDEF_CALL AstPredef.FALSE_n -> assert false
| PREDEF_CALL AstPredef.RCONST_n id -> assert false
| PREDEF_CALL AstPredef.ICONST_n id -> assert false
| PREDEF_CALL c -> "Lustre::"^(AstPredef.op2string_long c)
- | HAT _ -> assert false
| PRE -> "Lustre::pre"
| ARROW -> "Lustre::arrow"
| FBY-> "Lustre::fby"
| CURRENT -> "Lustre::current"
| CONCAT-> "Lustre::concat"
| ARRAY -> "Lustre::array"
+ | HAT _ -> "Lustre::hat"
| CALL n -> string_of_node_key n.it
| _ -> assert false
@@ -421,7 +436,7 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
let v = expr.Lic.ve_core in
match v with
| CallByNameLic(by_name_op_flg,fl) -> (
- (* Pas de composant pour les structures non plus. On se
+ (* Pas de soc pour les structures non plus. On se
contente d'éclater la structure en autant d'égalités
que nécessaire. *)
let lxm = by_name_op_flg.src in
@@ -435,24 +450,22 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
(fun (fn, fv) ->
let ft = fv.ve_typ in
let fv = val_exp_to_filter ctx.prg fv in
- (clk,
- [fv],
- [filter_to_field lpl fn.it ft],
- Soc.Assign,
- lxm
- )
+ (clk, [fv], [filter_to_field lpl fn.it ft], Soc.Assign, lxm)
)
fl
in
ctx, actions@al, iol, ml, deps
)
- | Merge(c_flg, cl) -> assert false
+ | Merge(c_flg, cl) ->
+ print_string "Merge not yet supported, sorry\n";
+ flush stdout;
+ assert false
| CallByPosLic (by_pos_op_flg, val_exp_list) -> (
match by_pos_op_flg.it with
(* handled via get_leaf *)
| Lic.ARRAY_SLICE _ | Lic.VAR_REF _ | Lic.CONST_REF _
| Lic.ARRAY_ACCES _ | Lic.STRUCT_ACCESS _ | Lic.TUPLE
- -> assert false
+ -> assert false (* XXX FINISH ME!!! *)
| Lic.WHEN ck -> (assert false
(* XXX FINISH ME!!! *)
(* (* L'opérateur when n'est pas un composant, il modifie *)
@@ -484,12 +497,12 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
(* ctx, actions_reclocked, outputs, mems, deps *)
)
- | HAT _ -> assert false (* XXX todo *)
- | ARRAY -> assert false (* XXX todo *)
+ | HAT _
+ | ARRAY
| CALL _
| PREDEF_CALL _
- | PRE | ARROW | FBY | CURRENT | CONCAT -> (
- (* build the soc of "expr" *)
+ | PRE | ARROW | FBY | CURRENT | CONCAT -> (
+ (* retreive the soc of "expr" in soc_tbl *)
let soc : Soc.t =
let id = by_pos_op_to_soc_ident by_pos_op_flg.it in
let args_types : Soc.var_type list =
@@ -508,16 +521,16 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
let sk = id, args_types_plus, None in
try Soc.SocMap.find sk soc_tbl
with Not_found ->
- let l = Soc.SocMap.bindings soc_tbl in
- let kl = fst (List.split l) in
- let klstr = List.map SocUtils.string_of_soc_key kl in
-
- print_string ("\n********* Cannot find the soc.key " ^
- (SocUtils.string_of_soc_key sk) ^ " in \n\t" ^
- (String.concat "\n\t" klstr)^"\n");
- flush stdout;
+ Verbose.exe ~flag:dbg (fun () ->
+ let l = Soc.SocMap.bindings soc_tbl in
+ let kl = fst (List.split l) in
+ let klstr = List.map SocUtils.string_of_soc_key kl in
+ print_string ("\n********* Cannot find the soc.key " ^
+ (SocUtils.string_of_soc_key sk) ^ " in \n\t" ^
+ (String.concat "\n\t" klstr)^"\n");
+ flush stdout;
+ );
raise (Undef_soc (sk, lxm, by_pos_op_flg.it, args_types))
-
in
(* Use that soc to build the corresponding
- actions
@@ -526,9 +539,9 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
*)
let inputs : Soc.var_expr list =
List.map (val_exp_to_filter ctx.prg) val_exp_list in
- let ctx, mem_opt = make_memory lxm clk ctx soc inputs lpl in
+ let ctx, mem_opt = make_instance lxm clk ctx soc in
let actions =
- let m2act = action_of_method lxm soc clk inputs lpl mem_opt in
+ let m2act = action_of_step lxm soc clk inputs lpl mem_opt in
List.map m2act soc.Soc.step
in
let dependances : ActionsDeps.t =
@@ -541,17 +554,15 @@ let rec (actions_of_expression_acc: Lxm.t -> Soc.tbl ->
let ml = match mem_opt with Some m -> m::ml | None -> ml in
(ctx, actions, lpl, ml, dependances)
)
+ )
)
- )
-
-
-
-(** Traduction d'une liste d'expressions. *)
-and (actions_of_expression_list: Lxm.t -> Soc.tbl -> Lic.clock -> Soc.var_expr list ->
- e2a_acc -> Lic.val_exp list -> e2a_acc) =
- fun lxm soc_tbl clk lpl expr_list acc ->
- List.fold_left (actions_of_expression_acc lxm soc_tbl clk lpl) expr_list acc
+
+ (** Traduction d'une liste d'expressions. *)
+ and (actions_of_expression_list: Lxm.t -> Soc.tbl -> Lic.clock -> Soc.var_expr list ->
+ e2a_acc -> Lic.val_exp list -> e2a_acc) =
+ fun lxm soc_tbl clk lpl expr_list acc ->
+ List.fold_left (actions_of_expression_acc lxm soc_tbl clk lpl) expr_list acc
let (actions_of_expression : Lxm.t -> Soc.tbl -> ctx -> Lic.clock -> Soc.var_expr list ->
@@ -567,7 +578,7 @@ let (actions_of_expression : Lxm.t -> Soc.tbl -> ctx -> Lic.clock -> Soc.var_exp
entre les variables issues de la traduction de l'expression et la partie
gauche de l'équation. *)
let (actions_of_equation: Lxm.t -> Soc.tbl -> ctx -> Lic.eq_info ->
- ctx * action list * memory list * ActionsDeps.t) =
+ ctx * action list * Soc.instance list * ActionsDeps.t) =
fun lxm soc_tbl ctx (left_part, right_part) ->
let clk = right_part.ve_clk in
let clk = match clk with [clk] -> clk | _ -> assert false in
@@ -586,23 +597,39 @@ let (actions_of_equation: Lxm.t -> Soc.tbl -> ctx -> Lic.eq_info ->
(** Traduit un noeud en composant Soc. *)
let rec (soc_of_node: LicPrg.t -> Lic.node_exp -> Soc.tbl -> (ctx * Soc.t) option) =
fun licprg node soc_tbl ->
+ let io_list = node.Lic.inlist_eff @ node.Lic.outlist_eff in
+ let io_type = List.map (fun vi -> lic_to_soc_type vi.var_type_eff) io_list in
+ let soc_key = Ident.string_of_long2 (fst node.Lic.node_key_eff), io_type, None in
match node.Lic.def_eff with
- | ExternLic -> None
- | MetaOpLic node_key -> None
- | AbstractLic None -> None (* None if extern in the provide part *)
+ | ExternLic ->
+ let soc = {
+ Soc.key = soc_key;
+ Soc.profile = soc_profile_of_node node;
+ Soc.instances = [] ;
+ Soc.step = [];
+ Soc.have_mem = None; (* XXX there is somthing todo if node.Lic.has_mem_eff; *)
+ Soc.precedences = [];
+ }
+ in
+(* Some(create_context licprg, soc) *)
+ print_string "Extern node not yet supported, sorry\n";
+ flush stdout;
+ assert false
+ | MetaOpLic node_key -> assert false
+ | AbstractLic None -> assert false (* None if extern in the provide part *)
| AbstractLic (Some node_exp) -> soc_of_node licprg node_exp soc_tbl
| BodyLic b ->
let lxm = node.lxm in
let ctx = create_context licprg in
- let ctx, actions, mems, deps =
+ let ctx, actions, instances, deps =
(* on itere sur la liste des équations *)
List.fold_left
- (fun (c, a, m, d) eq ->
- let nc, na, nm, nd = actions_of_equation eq.src soc_tbl c eq.it in
- nc, a @ na, m @ nm, (ActionsDeps.concat nd d)
+ (fun (c, a, i, d) eq ->
+ let nc, na, ni, nd = actions_of_equation eq.src soc_tbl c eq.it in
+ nc, a @ na, i @ ni, (ActionsDeps.concat nd d)
)
(ctx, [], [], ActionsDeps.empty)
- b.eqs_eff
+ b.eqs_eff
in
(* Construction des dépendances entre les expressions *)
let all_deps = ActionsDeps.build_data_deps_from_actions deps actions in
@@ -620,26 +647,17 @@ let rec (soc_of_node: LicPrg.t -> Lic.node_exp -> Soc.tbl -> (ctx * Soc.t) optio
| None -> []
| Some l -> List.map (lic_to_soc_var) l
in
- let meth = build_meth lxm "step" node (locals @ ctx.locals) actions in
- let profile = soc_profile_of_node node in
- let instances, init_actions = List.split mems in
- let init_meth = match init_actions with
- | [] -> None
- | actions -> Some (build_meth lxm "init" node [] (List.flatten actions))
- in
- let io_list = node.Lic.inlist_eff @ node.Lic.outlist_eff in
- let io_type = List.map (fun vi -> lic_to_soc_type vi.var_type_eff) io_list in
- let comp = {
- Soc.key = Ident.string_of_long2 (fst node.Lic.node_key_eff), io_type, None;
- Soc.profile = profile;
- Soc.instances = instances ;
- Soc.init = init_meth;
- Soc.step = [meth];
- Soc.precedences = []; (* TODO pour l'instant, on ne gère qu'une
- seule méthode *)
+ let step = build_step lxm "step" node (locals @ ctx.locals) actions in
+ let soc = {
+ Soc.key = soc_key;
+ Soc.profile = soc_profile_of_node node;
+ Soc.instances = instances ;
+ Soc.step = [step];
+ Soc.have_mem = None;
+ Soc.precedences = [];
}
in
- Some(ctx, comp)
+ Some(ctx, soc)
(*********************************************************************************)
@@ -674,45 +692,59 @@ let f: (LicPrg.t -> Lic.node_key -> Soc.key * Soc.tbl) =
(* Il manque une dépendance, on essaie de la
traduire puis de retraduire le noeud courant. *)
| Undef_soc (sk,lxm,Lic.CALL { it = nk2 }, types) ->
- let acc_comp = snd (process_node nk2 acc_comp) in
- snd (process_node nk acc_comp)
+ let acc_comp = snd (process_node nk2 acc_comp) in
+ snd (process_node nk acc_comp)
| Undef_soc (sk,lxm,pos_op, types) ->
let soc = SocPredef.soc_interface_of_pos_op lxm pos_op types in
+ assert (sk=soc.key);
let acc_comp = SocMap.add soc.key soc acc_comp in
+ let t = List.hd types in
+ (* The arrow is translated into a if. So we make sure that the "if"
+ is in the soc tbl *)
+ let if_sk = SocPredef.instanciate_name "Lustre::if" t, [Bool;t;t], None in
+ let acc_comp =
+ if pos_op = Lic.ARROW && not(SocMap.mem if_sk acc_comp) then
+ let soc = SocPredef.soc_interface_of_pos_op lxm
+ (Lic.PREDEF_CALL AstPredef.IF_n) [Bool;t;t]
+ in
+ SocMap.add soc.key soc acc_comp
+ else
+ acc_comp
+ in
snd (process_node nk acc_comp)
in
sk, acc_comp
- (* try *)
- (* *)
- (* let soc = SocPredef.of_soc_key sk in *)
- (* *)
- (* (match SocPredef.of_soc_key sk with *)
- (* | Some soc -> SocMap.add sk soc acc_comp *)
- (* | None -> *)
- (* try *)
- (* (match LicPrg.find_node prog nk with *)
- (* | None -> assert false *)
- (* | Some node_def -> *)
- (* (match soc_of_node prog node_def acc_comp with *)
- (* | Some(_,soc) -> SocMap.add sk soc acc_comp *)
- (* | None -> *)
- (* print_string ("Undefined soc : " ^ (string_of_node_key nk) ^ "\n"); *)
- (* flush stdout; *)
- (* acc_comp *)
- (* ) *)
- (* ) *)
- (* with *)
- (* | Undef_soc (sk,lxm,pos_op, types) -> *)
- (* (* Il manque une dépendance, on essaie de la *)
- (* traduire puis de retraduire le noeud courant. *) *)
- (* let soc = SocPredef.soc_interface_of_pos_op lxm pos_op types in *)
- (* let acc_comp = SocMap.add sk soc acc_comp in *)
- (* snd (process_node nk node acc_comp) *)
- (* ) *)
- (* in *)
- (* sk, acc_comp *)
- in
- process_node mnk SocMap.empty
+ (* try *)
+ (* *)
+ (* let soc = SocPredef.of_soc_key sk in *)
+ (* *)
+ (* (match SocPredef.of_soc_key sk with *)
+ (* | Some soc -> SocMap.add sk soc acc_comp *)
+ (* | None -> *)
+ (* try *)
+ (* (match LicPrg.find_node prog nk with *)
+ (* | None -> assert false *)
+ (* | Some node_def -> *)
+ (* (match soc_of_node prog node_def acc_comp with *)
+ (* | Some(_,soc) -> SocMap.add sk soc acc_comp *)
+ (* | None -> *)
+ (* print_string ("Undefined soc : " ^ (string_of_node_key nk) ^ "\n"); *)
+ (* flush stdout; *)
+ (* acc_comp *)
+ (* ) *)
+ (* ) *)
+ (* with *)
+ (* | Undef_soc (sk,lxm,pos_op, types) -> *)
+ (* (* Il manque une dépendance, on essaie de la *)
+ (* traduire puis de retraduire le noeud courant. *) *)
+ (* let soc = SocPredef.soc_interface_of_pos_op lxm pos_op types in *)
+ (* let acc_comp = SocMap.add sk soc acc_comp in *)
+ (* snd (process_node nk node acc_comp) *)
+ (* ) *)
+ (* in *)
+ (* sk, acc_comp *)
+ in
+ process_node mnk SocMap.empty
diff --git a/src/licPrg.ml b/src/licPrg.ml
index 28753423a65356ee8da1040ad67737bae8654681..6bdf2d81b4ac727aabf09c683cbf3855fea97eaa 100644
--- a/src/licPrg.ml
+++ b/src/licPrg.ml
@@ -62,6 +62,9 @@ let find_type this k = try Some(ItemKeyMap.find k this.types ) with Not_found -
let find_const this k = try Some(ItemKeyMap.find k this.consts) with Not_found -> None
let find_node this k = try Some(NodeKeyMap.find k this.nodes ) with Not_found -> None
+let node_exists this k = NodeKeyMap.mem k this.nodes
+
+
let (find_var : Ident.t -> Lic.node_exp -> Lic.var_info option) =
fun id ne ->
let name_matches vi = vi.Lic.var_name_eff = id in
@@ -84,6 +87,13 @@ let fold_nodes (f: Lic.node_key -> Lic.node_exp -> 'a -> 'a) (this:t) (accin:'a)
let list_nodes t = fold_nodes (fun k e acc -> (k,e)::acc) t []
+let choose_node t =
+ (* since ocaml 3.12.0 only... NodeKeyMap.choose *)
+ match list_nodes t with
+ | n::_ -> Some n
+ | [] -> None
+
+
let iter_consts (f: Lic.item_key -> Lic.const -> unit) (this:t) : unit =
ItemKeyMap.iter f this.consts
let iter_types (f: Lic.item_key -> Lic.type_ -> unit) (this:t) : unit =
@@ -104,42 +114,9 @@ let add_node (k:Lic.node_key) (v:Lic.node_exp) (prg:t) : t =
Printf.printf "## LicPrg.add_node %s\n" (LicDump.string_of_node_key_rec k));
{ prg with nodes = NodeKeyMap.add k v prg.nodes }
-
-let dump_entete oc =
- let time = Unix.localtime (Unix.time ()) in
- let sys_call, _ = Array.fold_left
- (fun (acc,i) x ->
- if 70 < i + (String.length x) then
- acc ^ "\n--\t\t" ^ x, String.length ("\n--\t\t" ^ x)
- else
- acc ^ " " ^ x , (i+1+(String.length x))
- )
- ("",0)
- Sys.argv
- and
- date = Printf.sprintf "%02d/%02d/%d"
- (time.Unix.tm_mday)
- (time.Unix.tm_mon+1)
- (1900+time.Unix.tm_year)
- and
- time_str = Printf.sprintf "%02d:%02d:%02d"
- (time.Unix.tm_hour)
- (time.Unix.tm_min)
- (time.Unix.tm_sec)
- (* and user = Unix.getlogin () *)
- and hostname = Unix.gethostname ()
- in
- (* Printf.fprintf oc "-- lus2lic version %s\n" Version.str; *)
- (* Printf.fprintf oc "-- cmd: %s\n" sys_call; *)
- (* Printf.fprintf oc "-- host: %s date: %s time: %s\n" hostname date time_str *)
- Printf.fprintf oc "-- This file was generated by lus2lic version %s.\n" Version.str;
- Printf.fprintf oc "-- %s\n" sys_call;
- Printf.fprintf oc "-- on %s the %s at %s\n" hostname date time_str
-
-
exception Print_me of Lic.node_exp
let to_file (oc: out_channel) (this:t) (main_node: Ident.idref option) =
- dump_entete oc;
+ Verbose.dump_entete oc;
(* On imprime dans l'ordre du iter, donc pas terrible ???
*)
ItemKeyMap.iter
diff --git a/src/licPrg.mli b/src/licPrg.mli
index cf13a38267564c7825b016ecf259f65e7f3fed35..bfdfdfef37df1ebae140fb4f75e38ea758557fa0 100644
--- a/src/licPrg.mli
+++ b/src/licPrg.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/02/2013 (at 16:05) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 17:30) by Erwan Jahier> *)
(** The data structure resulting from the compilation process *)
@@ -49,6 +49,8 @@ val to_file : out_channel -> t -> Ident.idref option -> unit
val find_type : t -> Lic.item_key -> Lic.type_ option
val find_const : t -> Lic.item_key -> Lic.const option
val find_node : t -> Lic.node_key -> Lic.node_exp option
+val node_exists: t -> Lic.node_key -> bool
+val choose_node : t -> (Lic.node_key * Lic.node_exp) option
val find_var : Ident.t -> Lic.node_exp -> Lic.var_info option
val fresh_type_id : t -> Ident.pack_name -> string -> Ident.long
diff --git a/src/main.ml b/src/main.ml
index 4b86a84360ab20984ad363690e88586c3067b318..abcb7c698c06a6d9bccaa83c5a6349578e3f0cb1 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/02/2013 (at 08:22) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 17:30) by Erwan Jahier> *)
@@ -168,7 +168,35 @@ let main = (
try (
let nsl = get_source_list !Global.infiles in
let lic_prg = Compile.doit nsl main_node in
- LicPrg.to_file !Global.oc lic_prg main_node;
+
+ if !Global.exec then
+ (match main_node with
+ | None -> (
+ let first_file = List.hd !Global.infiles in
+ let name =
+ try Filename.chop_extension (Filename.basename first_file)
+ with _ ->
+ print_string ("*** '"^first_file^"': bad file name.\n"); exit 1
+ in
+ let nk = (Lic.node_key_of_idref (Ident.to_idref name)) in
+ if LicPrg.node_exists lic_prg nk then (
+ print_string ("WARNING: No main node is specified. I'll try with " ^ name ^"\n");
+ flush stdout;
+ let msk, zesoc = Lic2soc.f lic_prg nk in
+ SocExec.f zesoc msk
+ ) else (
+ print_string ("Error: no node is specified, cannot exec.\n");
+ flush stdout;
+ exit 1
+ )
+ )
+ | Some main_node ->
+ let msk, zesoc = Lic2soc.f lic_prg (Lic.node_key_of_idref main_node) in
+ SocExec.f zesoc msk
+ ) else (
+ LicPrg.to_file !Global.oc lic_prg main_node
+ );
+
Verbose.exe ~level:3 (fun () -> Gc.print_stat stdout);
) with
Sys_error(s) ->
diff --git a/src/soc.ml b/src/soc.ml
index 9c1b43a8427ce7bc54b6ac0e258e0af922e0de90..32589e207a0d703af7b111fdf38c6f3963f6ddea 100644
--- a/src/soc.ml
+++ b/src/soc.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 11/03/2013 (at 09:23) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 15:46) by Erwan Jahier> *)
(** Synchronous Object Component *)
@@ -34,7 +34,7 @@ type var_expr =
type atomic_operation =
| Assign (* Wire *)
- | Method of instance (* node step call *)
+ | Method of instance * ident (* node step call ; the ident is the step name *)
| Procedure of key (* memoryless method made explicit (a good idea?) *)
@@ -44,13 +44,16 @@ type gao =
| Call of var_expr list * atomic_operation * var_expr list
(* outputs * op * inputs *)
-
type step_method = {
name : ident;
lxm : Lxm.t;
+(* XXX c'est laid ces histoires d'index. y'a qu'a recopier les
+ variables nécessaires et puis c'est marre !!! *)
idx_ins : int list; (* input index in the profile *)
idx_outs : int list; (* output index in the profile *)
impl : (var list * gao list) option; (* local vars + body ; None for predef op *)
+(* XXX Ã quoi sert cette liste de variables ??? (Parce que dans
+ SocPredef, je ne sais pas trop quoi y mettre...) *)
}
type precedence = ident * ident list
@@ -67,10 +70,12 @@ type t = {
key : key;
profile : var list * var list;
instances : instance list;
- init : step_method option;
+(* init : step_method option; *)
step : step_method list; (* the order in the list is a valid w.r.t.
the partial order defined in precedences *)
precedences : precedence list; (* partial order over step methods *)
+ have_mem : (var_type * var_expr option) option;
+ (* Do this soc have a memory (pre, fby, arrow) + its type + default value *)
}
(* SocKeyMap ? *)
diff --git a/src/socExecEvalPredef.ml b/src/socExecEvalPredef.ml
index bb898337c8dd7b4ea2639eafd03d9551549dd494..370be388596ac565b2529bd883546e17ea6df574 100644
--- a/src/socExecEvalPredef.ml
+++ b/src/socExecEvalPredef.ml
@@ -1,180 +1,348 @@
-(* Time-stamp: <modified the 07/03/2013 (at 16:51) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/03/2013 (at 14:24) by Erwan Jahier> *)
open SocExecValue
open Soc
(* A boring but simple module... *)
-let (lustre_iplus : substs -> subst) =
- fun s ->
- match (List.map snd s) with
- | [I i1; I i2] -> "z",I(i1+i2)
- | _ -> assert false
-
-let (lustre_rplus:substs -> subst) =
- fun s ->
- match (List.map snd s) with
- | [F i1; F i2] -> "z",F(i1+.i2)
- | _ -> assert false
-
-let lustre_itimes s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",I(x1 * x2)
- | _ -> assert false
-
-let lustre_rtimes s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",F(x1 *. x2)
- | _ -> assert false
-
-let lustre_idiv s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",I(x1 / x2)
- | _ -> assert false
-
-let lustre_rdiv s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",F(x1 /. x2)
- | _ -> assert false
-
-let lustre_iminus s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",I(x1 - x2)
- | _ -> assert false
-
-let lustre_rminus s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",F(x1 -. x2)
- | _ -> assert false
-
-let lustre_mod s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",I(x1 mod x2)
- | _ -> assert false
-
-let lustre_ieq s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",B(x1 = x2)
- | _ -> assert false
-
-let lustre_req s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",B(x1 = x2)
- | _ -> assert false
-
-let lustre_iuminus s =
- match (List.map snd s) with
- | [I x1] -> "z",I(- x1)
- | _ -> assert false
-
-let lustre_ruminus s =
- match (List.map snd s) with
- | [F x1] -> "z",F(-. x1)
- | _ -> assert false
-
-let lustre_real2int s =
- match (List.map snd s) with
- | [F x1] -> "z",I(int_of_float x1)
- | _ -> assert false
-
-let lustre_int2real s =
- match (List.map snd s) with
- | [I x1] -> "z",F(float_of_int x1)
- | _ -> assert false
-
-let lustre_not s =
- match (List.map snd s) with
- | [B x1] -> "z",B(not x1)
- | _ -> assert false
-
-let lustre_ilt s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",B(x1 < x2)
- | _ -> assert false
-
-let lustre_rlt s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",B(x1 < x2)
- | _ -> assert false
-
-let lustre_igt s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",B(x1 > x2)
- | _ -> assert false
-
-let lustre_rgt s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",B(x1 > x2)
- | _ -> assert false
-
-let lustre_ilte s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",B(x1 <= x2)
- | _ -> assert false
-
-let lustre_rlte s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",B(x1 <= x2)
- | _ -> assert false
-
-let lustre_igte s =
- match (List.map snd s) with
- | [I x1; I x2] -> "z",B(x1 >= x2)
- | _ -> assert false
-
-let lustre_rgte s =
- match (List.map snd s) with
- | [F x1; F x2] -> "z",B(x1 >= x2)
- | _ -> assert false
-
-let lustre_and s =
- match (List.map snd s) with
- | [B x1; B x2] -> "z",B(x1 && x2)
- | _ -> assert false
-let lustre_beq s =
- match (List.map snd s) with
- | [B x1; B x2] -> "z",B(x1 = x2)
- | _ -> assert false
-
-let lustre_neq s =
- match (List.map snd s) with
- | [B x1; B x2] -> "z",B(x1 <> x2)
- | _ -> assert false
-
-let lustre_or s =
- match (List.map snd s) with
- | [B x1; B x2] -> "z",B(x1 || x2)
- | _ -> assert false
-
-let lustre_impl s =
- match (List.map snd s) with
- | [B x1; B x2] -> "z",B(not x1 or x2)
- | _ -> assert false
-
-let lustre_xor s =
- let values = List.map snd s in
- let l = List.filter (fun x -> x=B true) values in
- "z",B(List.length l = 1)
-
-let lustre_iif s =
- match (List.map snd s) with
- | [B c; I x1; I x2] -> "z",I(if c then x1 else x2)
- | _ -> assert false
-
-let lustre_rif s =
- match (List.map snd s) with
- | [B c; F x1; F x2] -> "z",F(if c then x1 else x2)
- | _ -> assert false
-
-let lustre_bif s =
- match (List.map snd s) with
- | [B c; B x1; B x2] -> "z",B(if c then x1 else x2)
- | _ -> assert false
+let (lustre_iplus : ctx -> ctx) =
+ fun ctx ->
+ let ns =
+ match [get_val "x" ctx; get_val "y" ctx] with
+ | [I x1; I x2] -> "z"::ctx.cpath,I(x1+x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+let (lustre_rplus:ctx -> ctx) =
+ fun ctx ->
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F i1; F i2] -> "z"::ctx.cpath,F(i1+.i2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_itimes ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,I(x1 * x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rtimes ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,F(x1 *. x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_idiv ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,I(x1 / x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rdiv ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,F(x1 /. x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_iminus ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,I(x1 - x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rminus ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,F(x1 -. x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_mod ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,I(x1 mod x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_ieq ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,B(x1 = x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_req ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,B(x1 = x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+let lustre_iuminus ctx =
+ let ns =
+ match ([get_val "x" ctx]) with
+ | [I x1] -> "z"::ctx.cpath,I(- x1)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+let lustre_ruminus ctx =
+ let ns =
+ match ([get_val "x" ctx]) with
+ | [F x1] -> "z"::ctx.cpath,F(-. x1)
+ | [U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_real2int ctx =
+ let ns =
+ match ([get_val "x" ctx]) with
+ | [F x1] -> "z"::ctx.cpath,I(int_of_float x1)
+ | [U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_int2real ctx =
+ let ns =
+ match ([get_val "x" ctx]) with
+ | [I x1] -> "z"::ctx.cpath,F(float_of_int x1)
+ | [U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_not ctx =
+ let ns =
+ match ([get_val "x" ctx]) with
+ | [B x1] -> "z"::ctx.cpath,B(not x1)
+ | [U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_ilt ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,B(x1 < x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rlt ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,B(x1 < x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_igt ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,B(x1 > x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rgt ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,B(x1 > x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_ilte ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,B(x1 <= x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rlte ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,B(x1 <= x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_igte ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [I x1; I x2] -> "z"::ctx.cpath,B(x1 >= x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rgte ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [F x1; F x2] -> "z"::ctx.cpath,B(x1 >= x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_and ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [B x1; B x2] -> "z"::ctx.cpath,B(x1 && x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+let lustre_beq ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [B x1; B x2] -> "z"::ctx.cpath,B(x1 = x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_neq ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [B x1; B x2] -> "z"::ctx.cpath,B(x1 <> x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_or ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [B x1; B x2] -> "z"::ctx.cpath,B(x1 || x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_impl ctx =
+ let ns =
+ match ([get_val "x" ctx; get_val "y" ctx]) with
+ | [B x1; B x2] -> "z"::ctx.cpath,B(not x1 or x2)
+ | [U; _] | [_;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_iif ctx =
+ let ns =
+ match ([get_val "c" ctx; get_val "xt" ctx; get_val "xe" ctx]) with
+ | [B c; I x1; I x2] -> "z"::ctx.cpath,I(if c then x1 else x2)
+ | [B c; I x1; U] -> "z"::ctx.cpath,if c then I x1 else U
+ | [B c; U; I x2] -> "z"::ctx.cpath,if c then U else I x2
+ | [U;_; _] | [_;U;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_rif ctx =
+ let ns =
+ match ([get_val "c" ctx; get_val "xt" ctx; get_val "xe" ctx]) with
+ | [B c; F x1; F x2] -> "z"::ctx.cpath,F(if c then x1 else x2)
+ | [B c; F x1; U] -> "z"::ctx.cpath,if c then F x1 else U
+ | [B c; U; F x2] -> "z"::ctx.cpath,if c then U else F x2
+ | [U;_; _] | [_;U;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+let lustre_bif ctx =
+ let ns =
+ match ([get_val "c" ctx; get_val "xt" ctx; get_val "xe" ctx]) with
+ | [B c; B x1; B x2] -> "z"::ctx.cpath,B(if c then x1 else x2)
+ | [B c; B x1; U] -> "z"::ctx.cpath,if c then B x1 else U
+ | [B c; U; B x2] -> "z"::ctx.cpath,if c then U else B x2
+ | [U;_; _] | [_;U;U] -> "z"::ctx.cpath,U
+ | _ -> assert false
+ in
+ { ctx with s = sadd ctx.s ns }
+
+
+(* That one is different *)
+let lustre_xor ctx = assert false
+let lustre_diese ctx = assert false
+(* let ns = *)
+(* let values = [get_val "x" ctx; get_val "y" ctx] in *)
+(* let l = List.filter (fun x -> x=B true) values in *)
+(* "z"::ctx.cpath,B(List.length l = 1) *)
+
+
+
(* exported *)
-let (get: Soc.key -> (substs -> subst)) =
+let (get: Soc.key -> (ctx -> ctx)) =
fun (n,_,_) ->
match n with
| "Lustre::iplus" -> lustre_iplus
@@ -209,13 +377,14 @@ let (get: Soc.key -> (substs -> subst)) =
| "Lustre::neq" -> lustre_neq
| "Lustre::or" -> lustre_or
- | "Lustre::xor" -> lustre_xor
| "Lustre::impl" -> lustre_impl
| "Lustre::iif" -> lustre_iif
| "Lustre::rif" -> lustre_rif
| "Lustre::bif" -> lustre_bif
+ | "Lustre::xor" -> lustre_xor
+ | "Lustre::diese" -> lustre_diese
| _ -> raise Not_found
diff --git a/src/socExecEvalPredef.mli b/src/socExecEvalPredef.mli
index e96a3b5c08dad5f2a8b9986e57a7eb075828026d..3d1f3bff67e09cf4edef185382bdca9f838e7cf7 100644
--- a/src/socExecEvalPredef.mli
+++ b/src/socExecEvalPredef.mli
@@ -1,10 +1,7 @@
-(* Time-stamp: <modified the 07/03/2013 (at 16:52) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/03/2013 (at 14:18) by Erwan Jahier> *)
(** Returns a predef operator interpreter. Raises Not_found if the
operator is not defined.
-
- The interpreper supposes that the substitution do replace all inputs
- by values, and that types and arities are correct.
*)
-val get: Soc.key -> (SocExecValue.substs -> SocExecValue.subst)
+val get: Soc.key -> (SocExecValue.ctx -> SocExecValue.ctx)
diff --git a/src/socExecValue.ml b/src/socExecValue.ml
index 3bb73c7306beaf38868fa546cf9faa180579eef5..43742c3356692772e7fbdb06c04b5c20efa4e38d 100644
--- a/src/socExecValue.ml
+++ b/src/socExecValue.ml
@@ -1,11 +1,74 @@
-(* Time-stamp: <modified the 11/03/2013 (at 09:13) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 15:20) by Erwan Jahier> *)
open Soc
-type t = I of int | F of float | B of bool | E of Soc.ident
-type subst = (ident * t)
-type substs = subst list
+type t = I of int | F of float | B of bool | E of Soc.ident | U
+(* Meant to represent paths in the call tree. Actually it both
+ represent path and variable with a path, depending on the
+ context *)
+type path = ident list
+
+let (path_to_string: ident list -> string) =
+ fun l ->
+ String.concat "->" (List.rev l)
+
+type subst = (path * t)
+
+(* type substs = subst list *)
+type substs =
+ | Node of (ident * substs) list
+ | Leaf of t
+
+type ctx = {
+ cpath: path;
+ s:substs;
+}
+
+(* let rec (sadd : substs -> subst -> substs) = *)
+(* fun ct (x,v) -> *)
+(* (x,v)::(List.remove_assoc x ct) *)
+
+let (sadd : substs -> subst -> substs) =
+ fun ct (x,v) ->
+ let rec aux ct (x,v) =
+ match ct,x with
+ | Leaf(_),[] -> Leaf(v)
+ | Node(l),n::t -> (
+ try
+ let s = aux (List.assoc n l) (t,v) in
+ Node((n,s)::(List.remove_assoc n l))
+ with Not_found ->
+ if t = [] then Node((n,Leaf v)::l)
+ else
+ let new_substs = aux (Node []) (t,v) in
+ Node((n,new_substs)::l)
+ )
+ | _,[] -> assert false
+ | Leaf(_),_ -> assert false
+ in
+ aux ct (List.rev x,v)
+
+(* let filter_top_subst s = *)
+(* List.fold_left *)
+(* (fun acc (idl,v) -> *)
+(* match idl with *)
+(* | [id] -> (id,v)::acc *)
+(* | _ -> acc *)
+(* ) *)
+(* [] *)
+(* s *)
+
+let (filter_top_subst : substs -> (Soc.ident * t) list) =
+ fun s ->
+ let rec aux acc (id, s) =
+ match s with
+ | Leaf(v) -> (id,v)::acc
+ | _ -> acc
+ in
+ match s with
+ Node(l) -> List.fold_left aux [] l
+ | _ -> assert false
let (to_string : t -> string) =
function
@@ -14,6 +77,39 @@ let (to_string : t -> string) =
| B true -> "t"
| B false -> "f"
| E e -> e
+ | U -> "not initialised"
+
+let (string_of_subst_list : (path * t) list -> string) =
+ fun s ->
+ let values = List.map (fun (var,value) -> (path_to_string var)^"="^(to_string value)) s in
+ ((String.concat "\n\t" values) ^ "\n")
+
+let (dump_subst_list : (path * t) list -> unit) =
+ fun s ->
+ print_string (string_of_subst_list s);
+ flush stdout
+
+
+(* let (substs_to_list: substs -> (path * t) list) = *)
+(* fun s -> s *)
+
+let (substs_to_list: substs -> (path * t) list) =
+ fun s ->
+ let rec aux acc s p =
+ match s with
+ | Node(l) -> List.fold_left (fun acc (id,s) -> aux acc s (id::p)) acc l
+ | Leaf(v) -> (p,v)::acc
+ in
+ aux [] s []
+
+let (string_of_substs : substs -> string) =
+ fun s ->
+ string_of_subst_list (substs_to_list s)
+
+let (dump_substs : substs -> unit) =
+ fun s ->
+ dump_subst_list (substs_to_list s)
+
(* XXX use a Rif reader *)
let rec (read_enum : ident list -> ident) =
@@ -31,32 +127,49 @@ let (read_value : var -> t) =
| Enum(_,idl) -> E(read_enum(idl))
| _ -> assert false (* finish me! *)
-let (read_soc_input : Soc.t -> substs) =
- fun soc ->
- List.map (fun var -> Lic2soc.user_var_prefix^(fst var), read_value var) (fst soc.profile)
-
-let (string_of_substs :substs -> string) =
- fun s ->
- let str_l = List.map (fun (var,value) -> var ^ "->" ^ (to_string value)) s in
- "{ "^ (String.concat "; " str_l) ^ " }"
+(* let (get_val : ident -> ctx -> t) = *)
+(* fun id ctx -> *)
+(* try List.assoc (id::ctx.cpath) ctx.s *)
+(* with Not_found -> *)
+(* let msg = (path_to_string (id::ctx.cpath)) ^ " unbound in " *)
+(* ^ (string_of_substs ctx.s) *)
+(* in *)
+(* print_string msg; flush stdout; *)
+(* assert false *)
-let (get_val : ident -> substs -> t) =
- fun id s ->
- try List.assoc id s
+let (get_val : ident -> ctx -> t) =
+ fun id ctx ->
+ let rec find ct p =
+ match ct,p with
+ | Node(l),n::t -> find (List.assoc n l) t
+ | Leaf(v),[] -> v
+ | _,[] -> raise Not_found
+ | Leaf(_),_ -> assert false
+ in
+ try find ctx.s (List.rev (id::ctx.cpath))
with Not_found ->
- failwith (id ^ " unbound in " ^ (string_of_substs s))
+ let msg = (path_to_string (id::ctx.cpath)) ^ " unbound in \n"
+ ^ (string_of_substs ctx.s)
+ in
+ print_string msg; flush stdout;
+ assert false
-let (get_enum : ident -> substs -> ident) =
-fun id s ->
- match get_val id s with
+
+
+let (get_enum : ident -> ctx -> ident) =
+fun id ctx ->
+ match get_val id ctx with
| E e -> e
| _ -> assert false (* should not fail *)
-let (get_value : substs -> var_expr -> t) =
- fun s v ->
+
+(* XXX devrait prendre un ctx pour chercher aussi dans les memoires. *)
+
+let (get_value : ctx -> var_expr -> t) =
+ fun ctx v ->
match v with
- | Var(id,_) -> get_val id s
+ | Var(id,_) -> get_val id ctx
| Const("true",Bool) -> B true
| Const("false",Bool) -> B false
| Const(id_in,Int) -> I (int_of_string id_in)
@@ -65,27 +178,88 @@ let (get_value : substs -> var_expr -> t) =
| Field(_,_) -> assert false
| Index(_,_,_) -> assert false
-(* XXX use rif.dump *)
-let (dump_substs : var list * var list -> substs -> unit) =
- fun (ins,outs) s ->
- let values = List.map (fun (var,value) -> var^"="^(to_string value)) s in
- print_string ((String.concat " " values) ^ "\n");
- flush stdout
+
+
+
+
+(* type substs = subst list *)
+(* let (sadd : substs -> subst -> substs) = *)
+(* fun ss (x,v) -> *)
+(* let ss = List.remove_assoc x ss in *)
+(* (x,v)::ss *)
+
+(* let (string_of_substs :substs -> string) = *)
+(* fun s -> *)
+(* let str_l = *)
+(* List.map (fun (var,value) -> (path_to_string var) ^ "=" ^ (to_string value)) s *)
+(* in *)
+(* "{\n\t"^ (String.concat "\n\t" str_l) ^ " }" *)
+(* *)
+(* *)
+(* let (get_val : ident -> ctx -> t) = *)
+(* fun id ctx -> *)
+(* try List.assoc (id::ctx.cpath) ctx.s *)
+(* with Not_found -> *)
+(* let msg = (path_to_string (id::ctx.cpath)) ^ " unbound in " ^ (string_of_substs ctx.s) in *)
+(* print_string msg; flush stdout; *)
+(* assert false *)
+
(* exported *)
-let (substitute_args_and_params : var_expr list -> var list -> substs -> substs) =
- fun args params s ->
+let (substitute_args_and_params : var_expr list -> var list -> ctx -> substs) =
+ fun args params ctx ->
assert (List.length args = List.length params);
- List.map2 (fun arg (pn,_) -> pn, get_value s arg) args params
+ let arg_ctx = { ctx with cpath = List.tl ctx.cpath } in
+ let s = List.map2 (fun arg (pn,_) -> pn::ctx.cpath, get_value arg_ctx arg) args params in
+ let s = List.fold_left sadd ctx.s s in
+ s
-let (substitute_params_and_args : var list -> var_expr list -> substs -> substs) =
- fun params args s ->
+let (substitute_params_and_args : var list -> var_expr list -> ctx -> substs) =
+ fun params args ctx ->
assert (List.length args = List.length params);
- List.map2
+ let s = List.map2
(fun arg par ->
match arg,par with
- | Var(vn,_), (pn,_) -> vn, get_val pn s
+ | Var(vn,_), (pn,_) -> vn::(List.tl ctx.cpath), get_val pn ctx
| _,_ -> assert false
)
args params
+ in
+ let s = List.fold_left sadd ctx.s s in
+ s
+
+let empty_ctx: ctx = {
+ cpath = [];
+ s = Node [];
+}
+
+(* exported *)
+let rec (create_ctx : Soc.tbl -> Soc.t -> ctx) =
+ fun soc_tbl soc ->
+ let rec (init_soc: Soc.t -> ident list -> substs -> substs) =
+ fun soc cpath mem ->
+ let mem =
+ match soc.have_mem with
+ | Some(vt, Some(value)) ->
+ let name = (SocPredef.get_mem_name soc.key vt)::cpath in
+ let value = get_value empty_ctx value in
+ sadd mem (name,value)
+ | Some(vt, None) ->
+ let name = (SocPredef.get_mem_name soc.key vt)::cpath in
+ let value = U in
+ sadd mem (name,value)
+ | None -> mem
+ in
+ List.fold_left (init_instances cpath) mem soc.instances
+
+ and (init_instances: ident list -> substs -> Soc.instance -> substs) =
+ fun cpath mem (iname, sk) ->
+ let soc = SocUtils.find_no_exc sk soc_tbl in
+ init_soc soc (iname::cpath) mem
+ in
+ {
+ s = init_soc soc [] (Node []);
+ cpath = [];
+ }
+
diff --git a/src/socExecValue.mli b/src/socExecValue.mli
index 0e54c90ff51ab1c2b32fdcc984fdedf394349529..e53eaa7db88945531f3f7b2ecdef9c3fe1ad8597 100644
--- a/src/socExecValue.mli
+++ b/src/socExecValue.mli
@@ -1,24 +1,38 @@
-(* Time-stamp: <modified the 07/03/2013 (at 16:19) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 10:43) by Erwan Jahier> *)
(** Manipulating data in the Soc interpreter *)
-type t = I of int | F of float | B of bool | E of Soc.ident
-type subst = (Soc.ident * t)
-type substs = subst list
+type t = I of int | F of float | B of bool | E of Soc.ident | U (* to set uninitialized mem *)
+type subst = (Soc.ident list * t)
-val get_val : Soc.ident -> substs -> t
-val get_enum : Soc.ident -> substs -> Soc.ident
-val get_value : substs -> Soc.var_expr -> t
+type substs
+(* = *)
+(* | Node of (Soc.ident * substs) list *)
+(* | Leaf of t *)
+
+val sadd : substs -> subst -> substs
+
+
+type ctx = {
+ cpath:Soc.ident list;
+ s:substs;
+}
+
+(* Performs a recursive traversal of the top-level soc to init memories. *)
+val create_ctx : Soc.tbl -> Soc.t -> ctx
+
+
+val get_val : Soc.ident -> ctx -> t
+val get_enum : Soc.ident -> ctx -> Soc.ident
(* Pretty-printers *)
val to_string : t -> string
val string_of_substs :substs -> string
(* RIF I/O *)
-val dump_substs : Soc.var list * Soc.var list -> substs -> unit
+val dump_substs : substs -> unit
val read_enum : Soc.ident list -> Soc.ident
val read_value : Soc.var -> t
-val read_soc_input : Soc.t -> substs
(* if
args = [Var("x",Int); Const("3.14",Real) ]
@@ -32,5 +46,8 @@ then I want to output the follwing substitution :
nb : args and pars order matters
*)
-val substitute_args_and_params : Soc.var_expr list -> Soc.var list -> substs -> substs
-val substitute_params_and_args : Soc.var list -> Soc.var_expr list -> substs -> substs
+val substitute_args_and_params : Soc.var_expr list -> Soc.var list -> ctx -> substs
+val substitute_params_and_args : Soc.var list -> Soc.var_expr list -> ctx -> substs
+
+(* Returns the top-level variable substitutions in a RIF format *)
+val filter_top_subst : substs -> (Soc.ident * t) list
diff --git a/src/socPredef.ml b/src/socPredef.ml
index f3075412c7a41afdaaeba9f06b0ac3d9a4ab5de2..8cb367de06f5d2db78d322b87354500daccb4771 100644
--- a/src/socPredef.ml
+++ b/src/socPredef.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 11/03/2013 (at 09:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 19/03/2013 (at 10:13) by Erwan Jahier> *)
(** Synchronous Object Code for Predefined operators. *)
@@ -46,7 +46,7 @@ let (soc_profile_of_types : Soc.var_type list -> var list * var list) =
| [Soc.Bool;Soc.Int ;Soc.Int;Soc.Int] -> biii
| [Soc.Bool;Soc.Real;Soc.Real;Soc.Real] -> brrr
| tl ->
- (* should not occurs *)
+ (* diese and xor XXX todo *)
print_string ("Unsupported case: "^ (
String.concat "," (List.map SocUtils.string_of_type_ref tl)));
flush stdout;
@@ -73,11 +73,32 @@ let make_soc key profile steps = {
key = key;
profile = profile;
instances = [];
- init = None;
+(* init = None; *)
precedences = [];
step = steps;
+ have_mem = None;
}
+let (instanciate_name : string -> Soc.var_type -> string) =
+ fun id concrete_type ->
+ match Str.split (Str.regexp "::") id, concrete_type with
+ | ["Lustre";op], Soc.Int -> "Lustre::i" ^ op
+ | ["Lustre";op], Soc.Real -> "Lustre::r" ^ op
+ | ["Lustre";op], Soc.Bool -> "Lustre::b" ^ op
+ | _,_ -> id
+
+
+let first_instant = Var("first_instant", Bool)
+let (get_mem_name : Soc.key -> var_type -> string) =
+ fun (k,tl,_) vt ->
+ match Str.split (Str.regexp "::") k with
+ | ["Lustre";op] -> (
+ match op.[0] with
+ | 'i' | 'b' | 'r' -> String.set op 0 '_'; ("mem"^op)
+ | _ -> "mem_"^op
+ )
+ | _ -> "mem_"^k
+
(* exported *)
let of_soc_key : Soc.key -> Soc.t =
@@ -121,124 +142,159 @@ let of_soc_key : Soc.key -> Soc.t =
| "Lustre::current" -> (make_soc sk (sp tl) [step11])
- (* Those have instances *)
- | "Lustre::fby" -> {
- key = sk;
- profile = (sp tl);
- instances = [("fby_mem", sk)];
- step = [
- {
- name = "get";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [];
- idx_outs = [0];
- impl = None;
- };
- {
- name = "set";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [1];
- idx_outs = [];
- impl = None
- };
- ];
- precedences = ["set", ["get"]];
- init = Some {
- name = "init";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [0] ;
- idx_outs = [];
- impl = None;
- };
- }
+ (* Those have instances *)
- | "Lustre::pre" -> {
- key = sk;
- profile = (sp tl);
- instances = [("pre_mem", sk)];
- step = [
- {
- name = "get";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [];
- idx_outs = [0];
- impl = None;
- };
- {
- name = "set";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [0];
- idx_outs = [];
- impl = None
- };
- ];
- precedences = ["set", ["get"]];
- init = Some {
- name = "init";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [] ; (* XXX ??? *)
- idx_outs = [];
- impl = None;
- };
- }
+ | "Lustre::pre" ->
+ let _,tl,_ = sk in
+ let t = List.hd tl in
+ let pre_mem:var = (get_mem_name sk t, t) in
+ let prof = sp tl in
+ let v1,vout = match prof with ([v1],[vout]) -> v1,vout | _ -> assert false in
+ {
+ key = sk;
+ profile = (sp tl);
+ instances = [];
+ have_mem = Some (t, None); (* so that pre_mem exist *)
+ step = [
+ {
+ name = "get";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [];
+ idx_outs = [0];
+ impl = Some([pre_mem],[Call([Var(vout)], Assign, [Var(pre_mem)])]);
+ };
+ {
+ name = "set";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [0];
+ idx_outs = [];
+ impl = Some([pre_mem],[Call([Var(pre_mem)], Assign, [Var(v1)])]);
+ };
+ ];
+ precedences = ["set", ["get"]];
+ (* init = Some { *)
+ (* name = "init"; *)
+ (* lxm = Lxm.dummy "predef soc"; *)
+ (* idx_ins = [] ; (* XXX ??? *) *)
+ (* idx_outs = []; *)
+ (* impl = None; *)
+ (* }; *)
+ }
| "Lustre::arrow" ->
let prof = sp tl in
let v1,v2,vout = match prof with ([v1;v2],[vout]) -> v1,v2,vout | _ -> assert false in
let _,tl,_ = sk in
let t = List.hd tl in
- let init = Var("arrow_init", Bool) in
+ let pre_mem:var = (get_mem_name sk Bool, Bool) in
{
+ key = sk;
+ profile = prof;
+ instances = [];
+ step = [
+ {
+ name = "step";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [0;1];
+ idx_outs = [0];
+ impl = Some([],[Call([Var(vout)],
+ Procedure (instanciate_name "Lustre::if" t,
+ [Bool;t;t;t],None),
+ [Var(pre_mem);Var(v1);Var(v2)])]);
+ };
+ {
+ name = "update_first_instant";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [];
+ idx_outs = [-1];
+ impl = Some([],[Call([Var(pre_mem)], Assign, [Const("false",Bool)])]);
+ };
+ ];
+ precedences = ["update_first_instant",["step"]];
+ have_mem = Some (Bool, Some (Const("true",Bool)));
+
+ (* init = Some { *)
+ (* name = "init"; *)
+ (* lxm = Lxm.dummy "predef soc"; *)
+ (* idx_ins = [0]; *)
+ (* idx_outs = [0]; *)
+ (* impl = Some([],[Call([init], Assign, [Const("false",Bool)])]); *)
+ (* }; *)
+ }
+
+ | "Lustre::fby" ->
+ assert false
+ (* replace fby by '->' + 'pre' ?
+ let _,tl,_ = sk in
+ let t = List.hd tl in
+ let pre_mem:var = Var(get_mem_name sk, t) in
+ let v1,v2,vout = match prof with ([v1;v2],[vout]) -> v1,v2,vout | _ -> assert false in
+ {
+ key = sk;
+ profile = (sp tl);
+ instances = [("fby_mem", sk)];
+ step = [
+ {
+ name = "get";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [];
+ idx_outs = [0];
+ impl = Some([pre_mem],[Call([Var(vout)], Assign, [pre_mem])]);;
+ };
+ {
+ name = "set";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [1];
+ idx_outs = [];
+ impl = Some([pre_mem],[Call([pre_mem], Assign, [Var(v1)])]);;
+ have_mem = true;
+ };
+ ];
+ precedences = ["set", ["get"]];
+ init = Some {
+ name = "init";
+ lxm = Lxm.dummy "predef soc";
+ idx_ins = [0] ;
+ idx_outs = [];
+ impl = None;
+ };
+ } *)
+ | "Lustre::if" -> {
key = sk;
- profile = prof;
- instances = [("arrow_init",sk)];
- step = [
+ profile = (sp tl);
+ instances = [];
+ (* init = None; *)
+ precedences = [];
+ have_mem = None;
+ step = [
{
name = "step";
lxm = Lxm.dummy "predef soc";
- idx_ins = [0;1];
+ idx_ins = [0; 1; 2];
idx_outs = [0];
- impl = Some([],[Call([Var(vout)],
- Procedure ("Lustre::if", [Bool;t;t;t],None),
- [init;Var(v1);Var(v2)])]);
- };
+ impl = None;
+ }
];
- precedences = [];
- init = Some {
- name = "init";
- lxm = Lxm.dummy "predef soc";
- idx_ins = [0];
- idx_outs = [0];
- impl = Some([],[Call([init], Assign, [Const("false",Bool)])]);
- };
}
-
- | "Lustre::if" -> {
+ | "Lustre::hat" -> {
key = sk;
profile = (sp tl);
instances = [];
- init = None;
precedences = [];
+ have_mem = None;
step = [
{
name = "step";
lxm = Lxm.dummy "predef soc";
- idx_ins = [0; 1; 2];
+ idx_ins = [0; 1];
idx_outs = [0];
impl = None;
}
];
}
| _ ->
- print_string (id ^ " is not defined.\n)"); flush stdout;
+ print_string ("*** The soc of "^id ^ " is not defined. FINISH ME! \n"); flush stdout;
assert false
-let (instanciate_name : string -> Soc.var_type -> string) =
- fun id concrete_type ->
- match Str.split (Str.regexp "::") id, concrete_type with
- | ["Lustre";op], Soc.Int -> "Lustre::i" ^ op
- | ["Lustre";op], Soc.Real -> "Lustre::r" ^ op
- | ["Lustre";op], Soc.Bool -> "Lustre::b" ^ op
- | _,_ -> id
@@ -319,11 +375,15 @@ let make_slice_soc: Lic.slice_info -> Soc.var_type -> Soc.t =
};
];
precedences = [];
- init = None;
+ have_mem = None;
+(* init = None; *)
}
-
let make_array_soc: int -> Soc.var_type -> Soc.t =
+ fun i t ->
+ assert false
+
+let make_hat_soc: int -> Soc.var_type -> Soc.t =
fun i t ->
let array_type =
match t with
@@ -331,7 +391,7 @@ let make_array_soc: int -> Soc.var_type -> Soc.t =
| t -> Soc.Array(t,i)
in
{
- key = ("hat", [array_type], None);
+ key = ("Lustre::hat", [t;Int], None);
profile = (["t", t], ["st", array_type]);
instances = [];
step = [
@@ -344,7 +404,8 @@ let make_array_soc: int -> Soc.var_type -> Soc.t =
};
];
precedences = [];
- init = None;
+ have_mem = None;
+(* init = None; *)
}
@@ -452,27 +513,35 @@ let (soc_interface_of_pos_op:
| Lic.FBY, _ ->
let concrete_type = List.nth types 0 in
- let comp = of_soc_key (("Lustre::fby"), types@[concrete_type], None) in
- instanciate_soc comp concrete_type
+ let soc = of_soc_key (("Lustre::fby"), types@[concrete_type], None) in
+ instanciate_soc soc concrete_type
| Lic.PRE, _ ->
let concrete_type = List.nth types 0 in
- let comp = of_soc_key (("Lustre::pre"), types@[concrete_type], None) in
- instanciate_soc comp concrete_type
+ let soc = of_soc_key (("Lustre::pre"), types@[concrete_type], None) in
+ instanciate_soc soc concrete_type
| Lic.CURRENT, _ ->
let concrete_type = List.nth types 0 in
- let comp = of_soc_key (("Lustre::current"), types@[concrete_type], None) in
- instanciate_soc comp concrete_type
+ let soc = of_soc_key (("Lustre::current"), types@[concrete_type], None) in
+ instanciate_soc soc concrete_type
| Lic.ARROW, _ ->
let concrete_type = List.nth types 0 in
- let comp = of_soc_key (("Lustre::arrow"), types@[concrete_type], None) in
- let soc = instanciate_soc comp concrete_type in
- SocUtils.string_of_soc_ff soc Format.std_formatter;
+ let soc = of_soc_key (("Lustre::arrow"), types@[concrete_type], None) in
+ let soc = instanciate_soc soc concrete_type in
soc
| Lic.HAT i,_ ->
- let elt_type = List.nth types 0 in
- (make_array_soc i elt_type)
+ let concrete_type = List.nth types 0 in
+ let soc = of_soc_key (("Lustre::hat"), types@[concrete_type], None) in
+ let soc = instanciate_soc soc concrete_type in
+ soc
+(* let elt_type = List.nth types 0 in *)
+(* (make_hat_soc i elt_type) *)
+
+ | Lic.ARRAY, _ ->
+ let concrete_type = List.nth types 0 in
+ let soc = of_soc_key (("Lustre::array"), types@[concrete_type], None) in
+ let soc = instanciate_soc soc concrete_type in
+ soc
- | Lic.ARRAY, _-> finish_me lxm ; assert false
| Lic.CONCAT ,_-> finish_me lxm ; assert false
| Lic.CALL _,_ -> assert false (* XXX todo *)
@@ -495,7 +564,7 @@ dans des noeuds ? bon, je garde quelque temps en commentaire au cas ou...
| Lic.Fill(node,size), _
| Lic.FillRed(node,size), _
| Lic.Red(node,size), _ ->
- let comp = _key node with
+ let soc = _key node with
| Undef name -> Undef name
(* Given
- a node n of type
@@ -519,7 +588,7 @@ dans des noeuds ? bon, je garde quelque temps en commentaire au cas ou...
Some {
(* XXX la clef devrait contenir le node et la taille ?
- Les composants iterateurs ne meritent ils pas un traitement
+ Les socosants iterateurs ne meritent ils pas un traitement
specifique ?
Ce que je veux, c'est
- y mettre toute l'information necessaire pour pouvoir generer
@@ -543,7 +612,7 @@ dans des noeuds ? bon, je garde quelque temps en commentaire au cas ou...
}
)
| Lic.Map(node,size), _ ->
- let comp = _key node with
+ let soc = _key node with
| Undef name -> Undef name
| Some c ->
(* Given
diff --git a/src/socPredef.mli b/src/socPredef.mli
index 14bf10c83a8b56ec080ed55faaa35c0498571b6f..362ab1489338d5b308a7d4285b745f921d5da298 100644
--- a/src/socPredef.mli
+++ b/src/socPredef.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 07/03/2013 (at 11:11) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/03/2013 (at 21:54) by Erwan Jahier> *)
(** Synchronous Object Code for Predefined operators. *)
@@ -10,10 +10,11 @@ val of_soc_key : Soc.key -> Soc.t
Le type des opérandes permet de traiter les opérateurs surchargés.
*)
-
val soc_interface_of_pos_op:
Lxm.t -> Lic.by_pos_op -> Soc.var_type list -> Soc.t
val instanciate_name : string -> Soc.var_type -> string
+
+val get_mem_name : Soc.key -> Soc.var_type -> string
diff --git a/src/socUtils.ml b/src/socUtils.ml
index 0882f76585f75fed915431cb5e9404c75c74eebe..7c982d479d84286f1ee48aeffa5288555909baf8 100644
--- a/src/socUtils.ml
+++ b/src/socUtils.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 11/03/2013 (at 09:24) by Erwan Jahier> *)
+(** Time-stamp: <modified the 13/03/2013 (at 22:25) by Erwan JAHIER> *)
open Soc
@@ -9,9 +9,11 @@ open Soc
C'est la liste des méthodes du composant, et la méthode d'initialisation le
cas échéant. *)
let get_all_methods: Soc.t -> step_method list = fun c ->
- match c.init with
- | None -> c.step
- | Some m -> m :: c.step
+ c.step
+(* DELETE ME !! *)
+(* match c.init with *)
+(* | None -> c.step *)
+(* | Some m -> m :: c.step *)
(** Fonctions de représentation des objets LOC. *)
@@ -92,8 +94,8 @@ let string_of_instance: (instance -> string) = fun (name,sk) -> name
(* Opération *)
let string_of_operation_ff: (atomic_operation -> Format.formatter -> unit) = fun v ff -> match v with
| Assign -> () (* On suppose qu'il est déjà affiché dans string_of_gao *)
- | Method(n, sk) -> fprintf ff "%s.%s" n (string_of_soc_key sk)
- | Procedure proc -> fprintf ff "%s" (string_of_soc_key proc)
+ | Method((n, sk),sname) -> fprintf ff "%s.%s" n sname
+ | Procedure(proc) -> fprintf ff "%s" (string_of_soc_key proc)
let string_of_operation: (atomic_operation -> string) = fun v ->
call_fun_ff (string_of_operation_ff v)
@@ -152,6 +154,7 @@ let string_of_gaos_list: (gao list -> string) = fun v ->
(* Profil de méthode *)
let string_interface_of_method_ff: (Soc.t -> step_method -> Format.formatter -> unit) = fun c m ff ->
let string_var_from_index: (Soc.var list -> int -> string) = fun vl i ->
+ if i < 0 then "mem" else
string_of_var (List.nth vl i)
in
fprintf ff "%s(%s) -> (%s)"
@@ -242,14 +245,15 @@ let string_of_soc_factory_ff: (
) comp.instances
)
in
- let display_init () =
- match comp.init with
- | None -> fprintf ff "@[<v 2>init: -@]"
- | Some m -> (
- fprintf ff "@[<v 2>init:@,";
- format_meth comp m ff;
- fprintf ff "@]"
- )
+ let display_init () = ()
+(* DELETE ME !! *)
+(* match comp.init with *)
+(* | None -> fprintf ff "@[<v 2>init: -@]" *)
+(* | Some m -> ( *)
+(* fprintf ff "@[<v 2>init:@,"; *)
+(* format_meth comp m ff; *)
+(* fprintf ff "@]" *)
+(* ) *)
in
fprintf ff "@[<v>@[<v 2>soc ";
@@ -348,6 +352,7 @@ let output: (bool -> string -> Soc.t list -> unit) =
flush stdout
+
let (find : Lxm.t -> Soc.key -> Soc.tbl -> Soc.t) =
fun lxm sk soc_tbl ->
try SocMap.find sk soc_tbl
@@ -362,6 +367,14 @@ let (find : Lxm.t -> Soc.key -> Soc.tbl -> Soc.t) =
in
raise (Errors.Compile_error(lxm,msg))
+let (find_no_exc : Soc.key -> Soc.tbl -> Soc.t) =
+ fun sk soc_tbl ->
+ try find (Lxm.dummy "") sk soc_tbl
+ with Errors.Compile_error(_,msg) ->
+ print_string msg;
+ flush stdout;
+ assert false
+
diff --git a/src/socUtils.mli b/src/socUtils.mli
index d71239c0f4cdf66091ff6648ca64fb5b36130c8e..91ffcd116d54a0f9b8a636e84c79d6240e521cc5 100644
--- a/src/socUtils.mli
+++ b/src/socUtils.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 11/03/2013 (at 09:24) by Erwan Jahier> *)
+(** Time-stamp: <modified the 13/03/2013 (at 11:10) by Erwan Jahier> *)
(** Donne toute les méthodes d'un composant. *)
@@ -39,4 +39,8 @@ val string_of_soc_ff : Soc.t -> Format.formatter -> un
should be printed *)
val output: bool -> string -> Soc.t list -> unit
+(* Raise a compile error in not found *)
val find : Lxm.t -> Soc.key -> Soc.tbl -> Soc.t
+
+(* Raise an internal error if not found *)
+val find_no_exc : Soc.key -> Soc.tbl -> Soc.t
diff --git a/src/verbose.ml b/src/verbose.ml
index 64db59f45397adfc10c0cea709b9e5e7f28ea5b4..93a9315cf53fed92896b507c0525499f380608ad 100644
--- a/src/verbose.ml
+++ b/src/verbose.ml
@@ -102,3 +102,37 @@ let put s = (
*)
(* put "%d %s %d\n" 42 "toto" 43; flush stderr;; *)
+
+(* exported *)
+let (dump_entete : out_channel -> unit) =
+ fun oc ->
+ let time = Unix.localtime (Unix.time ()) in
+ let sys_call, _ = Array.fold_left
+ (fun (acc,i) x ->
+ if 70 < i + (String.length x) then
+ acc ^ "\n--\t\t" ^ x, String.length ("\n--\t\t" ^ x)
+ else
+ acc ^ " " ^ x , (i+1+(String.length x))
+ )
+ ("",0)
+ Sys.argv
+ and
+ date = Printf.sprintf "%02d/%02d/%d"
+ (time.Unix.tm_mday)
+ (time.Unix.tm_mon+1)
+ (1900+time.Unix.tm_year)
+ and
+ time_str = Printf.sprintf "%02d:%02d:%02d"
+ (time.Unix.tm_hour)
+ (time.Unix.tm_min)
+ (time.Unix.tm_sec)
+ (* and user = Unix.getlogin () *)
+ and hostname = Unix.gethostname ()
+ in
+ (* Printf.fprintf oc "-- lus2lic version %s\n" Version.str; *)
+ (* Printf.fprintf oc "-- cmd: %s\n" sys_call; *)
+ (* Printf.fprintf oc "-- host: %s date: %s time: %s\n" hostname date time_str *)
+ Printf.fprintf oc "-- This file was generated by lus2lic version %s.\n" Version.str;
+ Printf.fprintf oc "-- %s\n" sys_call;
+ Printf.fprintf oc "-- on %s the %s at %s\n" hostname date time_str
+
diff --git a/src/verbose.mli b/src/verbose.mli
index 6dd664ff30a8c13213492ef3bec7075d94a28a95..f8f13b2abd707d977f49fe7b8156028f3edf880a 100644
--- a/src/verbose.mli
+++ b/src/verbose.mli
@@ -45,3 +45,5 @@ val flag_list : unit -> string list
val printf : ?level:int -> ?flag:flag option -> ('a, unit, string, unit) format4 -> 'a
val print_string : ?level:int -> ?flag:flag option -> string -> unit
val exe : ?level:int -> ?flag:flag option -> (unit -> unit) -> unit
+
+val dump_entete : out_channel -> unit
diff --git a/todo.org b/todo.org
index ef401638081c14eacf1941e22606e4589536a90f..e1673d909864b08a2531d5bdcd59d77873794277 100644
--- a/todo.org
+++ b/todo.org
@@ -1,6 +1,36 @@
#+TODO: TODO(!) STARTED(!) WAITING(!) | DONE(d!) CANCELED(c)
#+CATEGORY: lv6
+* lus2lic -exec
+** TODO Trouver un moyen d'automatiser des tests
+ - State "TODO" from "" [2013-03-19 Tue 10:35]
+via lurette ?
+faudrait rajouter une option dans lurette qui, en cas de varaibles
+manquantes, genere le programme lutin qui va bien (loop true) plutot
+que de lancer luciole
+
+--auto-stubs
+
+** TODO Écrire un test qui mette en jeu exhaustivement tous les operateurs
+ - State "TODO" from "" [2013-03-19 Tue 10:38]
+
+** TODO revoir l'intégration à rif_base et genlex
+ - State "TODO" from "" [2013-03-19 Tue 10:25]
+** TODO Découper un peu les fonctions dans src/lic2soc.ml
+ - State "TODO" from "" [2013-03-19 Tue 10:26]
+le role et le perimetre get_leaf en particulier n'est pas clair.
+de plus son code est dupliqué.
+file:src/lic2soc.ml
+** TODO fonctions externes
+ - State "TODO" from "" [2013-03-19 Tue 10:33]
+** TODO tableaux (hat, array, etc)
+ - State "TODO" from "" [2013-03-19 Tue 10:33]
+** TODO condact, merge
+ - State "TODO" from "" [2013-03-19 Tue 10:33]
+** TODO when, current
+ - State "TODO" from "" [2013-03-19 Tue 10:33]
+** TODO meta operateurs
+ - State "TODO" from "" [2013-03-19 Tue 10:33]
* Packages, modeles, etc.
** STARTED Il ne detecte plus les erreurs de type lors d'instanciation de noeuds