diff --git a/Makefile b/Makefile
index ef317c6f255d60b63672f001bf212bd7258cb1b2..9b917d598c76d9577c8978d5b5bba239d799822d 100644
--- a/Makefile
+++ b/Makefile
@@ -153,6 +153,7 @@ lus2lic:
make test
+
# TEST, NON REGR. ETC...
TESTDIR=./tests
@@ -202,3 +203,10 @@ cia: $(OBJDIR)/version.ml
amend:
git commit -a -F log --amend && rm -f $(OBJDIR)/version.ml
+
+push:
+ git push git+ssh://jahier@scm.forge.imag.fr/var/lib/gforge/chroot/scmrepos/git/lustre/lustre.git
+
+xxx:
+remote add --track master origin git+ssh://jahier@scm.forge.imag.fr/var/lib/gforge/chroot/scmrepos/git/lustre/lustre.git
+
diff --git a/README.org b/README.org
index ea27e17444541ad3723da37b669bbd75b2d9cd0e..f875b80eebae91d7491b2b9858da9c8f92d3b16f 100644
--- a/README.org
+++ b/README.org
@@ -34,47 +34,111 @@ exit code > 0.
* src
-file:///home/jahier/lus2lic/ocamldoc/index.html
+file:ocamldoc/index.html
Here follows a description of the different modules used by this
lus2lic compiler (in src)
-** First of all, the Lustre files are parsed,
+** First of all, the Lustre files are parsed, and put input tables
+
+lxm.ml
+lxm.mli
+lexer.mll
+parser.mly
+parserUtils.ml
+astCore.ml
+astV6.ml
+astPredef.ml
+ident.ml
+ident.mli
+
+** and put input tables performing some checks along the way (references)
+
+astTab.ml
+astTab.mli
+astTabSymbol.ml
+astTabSymbol.mli
+astV6Dump.ml
+astV6Dump.mli
+
+** Some source to source manip are performed of those tables
+
+astInstanciateModel.ml
+astInstanciateModel.mli
+astRecognizePredef.ml
+astRecognizePredef.mli
+
+** Then the source is statically evaluated and type/clock checked
+
+ast2lic.ml
+ast2lic.mli
+lic.ml
+licTab.ml
+licTab.mli
+licDump.ml
+licDump.mli
+licMetaOp.ml
+licMetaOp.mli
+licName.ml
+licName.mli
+licPredef.ml
+licEvalClock.ml
+licEvalClock.mli
+licEvalConst.ml
+licEvalConst.mli
+licEvalType.ml
+licEvalType.mli
+evalClock.ml
+evalClock.mli
+evalConst.ml
+evalConst.mli
+evalType.ml
+evalType.mli
+unifyClock.ml
+unifyClock.mli
+unifyType.ml
+unifyType.mli
+
+
+** Lic is transformed into a LicPrg (imperative table->functional maps)
+
+licPrg.ml
+licPrg.mli
+
+** Some source to source manip are performed
+
+l2lAliasType.ml
+l2lAliasType.mli
+l2lCheckOutputs.ml
+l2lCheckOutputs.mli
+l2lExpandArrays.ml
+l2lExpandArrays.mli
+l2lExpandNodes.ml
+l2lExpandNodes.mli
+l2lRmPoly.ml
+l2lRmPoly.mli
+l2lSplit.ml
+l2lSplit.mli
+
+** All this don from a main program
+
+main.ml
+mainArgs.ml
+mainArgs.mli
+global.ml
+compile.ml
+compile.mli
- lexer.mll
- parser.mly
- parserUtils.ml
- lxm.mli/ml
-
-which results into a parse tree containing raw source expressions.
-
- syntaxTreeCore.ml, syntaxTree.ml -> should rather be called rawSyntaxTab.ml ? or just Src ?
-
-
-** Then, we perform reference checking at module level + model expansion.
-
- syntaxTab.mli/ml
- syntaxTabUtil.ml/mli
- instanciateModel.mli/ml
- symbolTab.mli/ml (type/const/node)
-
-syntaxTab is a kind of layer above syntaxTree to make things easier afterwards.
-
-
-** Finally, the compilation (type checking+const/type evaluation) is performed.
+** Some misc (eponymous) modules are used along the way.
- compile.ml
- lazyCompiler.mli/ml
- evalConst.mli/ml
- evalType.mli/ml
- compiledData.ml
-
+verbose.ml
+verbose.mli
+filenameExtras.ml
+filenameExtras.mli
+errors.ml
-** Some misc (eponymous) modules are used along the way.
- errors.ml
- verbose.mli/ml
- version.ml
- ident.ml
+** crutch to remove
+uglyStuff.ml
* todo
diff --git a/src/compile.ml b/src/compile.ml
index fb1035392a32021f3675756445a348873f2840e4..0d5718672320632cb1a0ab9756d57e00b6257618 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 10:50) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/12/2012 (at 16:51) by Erwan Jahier> *)
open Lxm
@@ -27,19 +27,19 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
. dans un des packs déclarés "uses", avec
priorité dans l'ordre
*)
- let lzcomp = LicTab.create syntax_tab in
+ let lic_tab = LicTab.create syntax_tab in
Verbose.exe ~level:2 (fun () -> AstTab.dump syntax_tab);
Ident.set_dft_pack_name (first_pack_in srclist);
- let zelazy = match main_node with
- | None -> LicTab.compile_all lzcomp
+ let lic_tab = match main_node with
+ | None -> LicTab.compile_all lic_tab
| Some main_node ->
if !Global.compile_all_items then
- LicTab.compile_all lzcomp
+ LicTab.compile_all lic_tab
else
- LicTab.compile_node lzcomp main_node
+ LicTab.compile_node lic_tab main_node
in
- let zelic = LicTab.to_lic zelazy in
+ let zelic = LicTab.to_lic_prg lic_tab in
(* élimination polymorphisme surcharge *)
let zelic = L2lRmPoly.doit zelic in
@@ -48,7 +48,12 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
let zelic = L2lAliasType.doit zelic in
(* split des equations (1 eq = 1 op) *)
- let zelic = L2lSplit.doit zelic in
+ let zelic = if !Global.one_op_per_equation then L2lSplit.doit zelic else zelic in
+(* let zelic = *)
+(* if !Global.expand_structs *)
+(* then L2lExpandArrays.doit id_solver lenv zelic *)
+(* else zelic *)
+(* in *)
(* XXX node et array expand ! *)
diff --git a/src/l2lExpandArrays.ml b/src/l2lExpandArrays.ml
index f6fa5fea1bcd7b5916e3d7964a65795a68aca491..56ae81f6063939c623c32c10ae27129422cb1bcf 100644
--- a/src/l2lExpandArrays.ml
+++ b/src/l2lExpandArrays.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 13/12/2012 (at 11:32) by Erwan Jahier> *)
+(** Time-stamp: <modified the 13/12/2012 (at 16:28) 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...
@@ -62,8 +62,9 @@ let clone_var node_env vi str type_eff =
let clk_id = Ident.of_string str in
let type_eff = match type_eff with
TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error "L2lExpandArrays.clone" "should not have been called for a any(num) var";
- assert false
+ Errors.print_internal_error
+ "L2lExpandArrays.clone" "should not have been called for a any(num) var";
+ assert false
| _ -> type_eff
in
@@ -76,16 +77,17 @@ let clone_var node_env vi str type_eff =
var_clock_eff = clk_id, snd vi.var_clock_eff;
}
in
-(* Hashtbl.add node_env.lenv_vars id var; *)
- var
+ (* Hashtbl.add node_env.lenv_vars id var; *)
+ var
let rec (is_a_basic_type : Lic.type_ -> bool) =
function
| Array_type_eff _ | Struct_type_eff _ -> false
| TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error "L2lExpandArrays.is_a_basic_type" "should not have been called for a any(num) var";
- assert false
+ Errors.print_internal_error
+ "L2lExpandArrays.is_a_basic_type" "should not have been called for a any(num) var";
+ assert false
| Abstract_type_eff(_, teff) -> is_a_basic_type teff
| External_type_eff(_)
| Enum_type_eff (_, _)
@@ -143,36 +145,37 @@ let rec (flatten_var_tree : 'a var_tree -> 'a list) =
| L str -> [str]
let rec (gen_var_trees :
- (string -> Lic.type_ -> 'a) -> string -> Lic.type_ -> 'a var_tree) =
+ (string -> Lic.type_ -> 'a) -> string -> Lic.type_ -> 'a var_tree) =
fun make_leave prefix teff ->
let loop = gen_var_trees make_leave in
- match teff with
- | TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error "L2lExpandArrays.gen_var_trees" "should not have been called for a any(num) var";
- assert false
- | Bool_type_eff | Int_type_eff | Real_type_eff
- | Enum_type_eff(_) | External_type_eff(_)
- ->
- L (make_leave prefix teff)
-
- | Abstract_type_eff(_,teff) -> loop prefix teff
-
- | Array_type_eff(teff_elt,i) ->
- let rec unfold acc cpt =
- if cpt < 0 then acc else
- let prefix = prefix ^ "_" ^ (soi cpt) in
- let vt = loop prefix teff_elt in
- unfold (vt::acc) (cpt-1)
- in
- A (unfold [] (i-1))
-
- | Struct_type_eff(_, fl) ->
- S (List.map
- (fun (fn, (steff, _const_opt)) ->
- let prefix = prefix^"_"^(Ident.to_string fn) in
- (fn, loop prefix steff )
- )
- fl)
+ match teff with
+ | TypeVar Any | TypeVar AnyNum ->
+ Errors.print_internal_error
+ "L2lExpandArrays.gen_var_trees" "should not have been called for a any(num) var";
+ assert false
+ | Bool_type_eff | Int_type_eff | Real_type_eff
+ | Enum_type_eff(_) | External_type_eff(_)
+ ->
+ L (make_leave prefix teff)
+
+ | Abstract_type_eff(_,teff) -> loop prefix teff
+
+ | Array_type_eff(teff_elt,i) ->
+ let rec unfold acc cpt =
+ if cpt < 0 then acc else
+ let prefix = prefix ^ "_" ^ (soi cpt) in
+ let vt = loop prefix teff_elt in
+ unfold (vt::acc) (cpt-1)
+ in
+ A (unfold [] (i-1))
+
+ | Struct_type_eff(_, fl) ->
+ S (List.map
+ (fun (fn, (steff, _const_opt)) ->
+ let prefix = prefix^"_"^(Ident.to_string fn) in
+ (fn, loop prefix steff )
+ )
+ fl)
let (expand_left : Lic.local_env -> left -> left list) =
fun nenv left ->
@@ -216,7 +219,7 @@ let (expand_left : Lic.local_env -> left -> left list) =
(** build a new loc that will alias ve, and add its definition in the
set of equations (cf acc) *)
let rec (make_new_loc : Lic.local_env -> Lic.id_solver -> Lxm.t -> acc ->
- Lic.val_exp -> acc * var_info) =
+ Lic.val_exp -> acc * var_info) =
fun nenv id_solver lxm acc ve ->
let teff = List.hd ve.ve_typ in
let ceff = List.hd ve.ve_clk in
@@ -225,182 +228,180 @@ let rec (make_new_loc : Lic.local_env -> Lic.id_solver -> Lxm.t -> acc ->
let neq = flagit neq lxm in
let nvl, (asserts,eqs,locs) = expand_var_info nenv id_solver ([],acc) nv in
let acc = (asserts,eqs, List.rev_append nvl locs) in
- expand_eq nenv id_solver acc neq, nv
+ expand_eq nenv id_solver acc neq, nv
and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
- -> acc * Lic.val_exp var_tree) =
+ -> acc * Lic.val_exp var_tree) =
fun nenv id_solver acc ve ->
let make_val_exp nenv lxm vi prefix teff =
let prefix = (Ident.to_string vi.var_name_eff) ^ prefix in
let id = prefix in
{
- ve_core = CallByPosLic({src=lxm;it=(VAR_REF id)}, OperLic []);
- ve_typ = [vi.var_type_eff] ;
- ve_clk = [snd vi.var_clock_eff]
+ ve_core = CallByPosLic({src=lxm;it=(VAR_REF id)}, OperLic []);
+ ve_typ = [vi.var_type_eff] ;
+ ve_clk = [snd vi.var_clock_eff]
}
in
let loop = var_trees_of_val_exp nenv id_solver acc in
- match ve.ve_core with
- | CallByPosLic (by_pos_op, OperLic vel) -> (
- let lxm = by_pos_op.src in
- let by_pos_op = by_pos_op.it in
- match by_pos_op with
- | STRUCT_ACCESS (id) -> (
- let ve = try List.hd vel with _ -> assert false in
- match loop ve with
- | acc, S fl -> acc, List.assoc id fl
- | _, (A _ | L _) -> assert false
- )
- | ARRAY_ACCES (i) -> (
- let ve = try List.hd vel with _ -> assert false in
- match loop ve with
- | acc, A array -> acc, List.nth array i
- | _, (S _ | L _) -> assert false
-
- )
- | ARRAY_SLICE (si) -> (
- let ve = try List.hd vel with _ -> assert false in
- match loop ve with
- | acc, A array ->
- let index_list = index_list_of_slice_info si in
- let l = List.map (fun i -> List.nth array i) index_list in
- acc, A l
-
- | _, (S _ | L _) -> assert false
- )
- | VAR_REF id -> (
- try
- let vi = UglyStuff.var_info_of_ident id_solver id lxm in
- (acc, gen_var_trees (make_val_exp nenv lxm vi) "" vi.var_type_eff)
-
- with _ ->
- let msg =
- "\n*** during Array expansion: '"^
- (id)^
- "': Unknown variable.\n"^
- "*** Current variables are: "^
- (Hashtbl.fold
- (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
- nenv.lenv_vars "")
- in
- raise (Errors.Compile_error(lxm, msg))
- )
- | CONST_REF idl -> (
- try
- let const = UglyStuff.const_eff_of_item_key id_solver idl lxm in
- let s, ve_const =
- UnifyClock.const_to_val_eff lxm true UnifyClock.empty_subst const
- in
- let ve_const,acc =
- match ve_const.ve_core with
- | CallByPosLic ({it=CONST_REF _},_) ->
- (* in order to avoid a potential infinite loop *)
- (ve_const, acc)
-
- | _ -> expand_val_exp nenv id_solver acc ve_const
- in (acc, L (ve_const))
- with _ ->
- let msg =
- "\n*** during Array expansion: '"^
- (Ident.string_of_long idl)^
- "': Unknown variable.\n"^
- "*** Current variables are: "^
- (Hashtbl.fold
- (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
- nenv.lenv_vars "")
- in
- raise (Errors.Compile_error(lxm, msg))
- )
- | WITH(_) | HAT(_) | CONCAT | ARRAY(_)
- | PREDEF_CALL _ | CALL _ | MERGE _
- | PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE -> (
- (* Create a new loc var to alias such expressions *)
- let acc, nloc = make_new_loc nenv id_solver lxm acc ve in
- acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
- )
- )
- | CallByNameLic(by_name_op, fl) ->
- let lxm = by_name_op.src in
+ match ve.ve_core with
+ | CallByPosLic (by_pos_op, OperLic vel) -> (
+ let lxm = by_pos_op.src in
+ let by_pos_op = by_pos_op.it in
+ match by_pos_op with
+ | STRUCT_ACCESS (id) -> (
+ let ve = try List.hd vel with _ -> assert false in
+ match loop ve with
+ | acc, S fl -> acc, List.assoc id fl
+ | _, (A _ | L _) -> assert false
+ )
+ | ARRAY_ACCES (i) -> (
+ let ve = try List.hd vel with _ -> assert false in
+ match loop ve with
+ | acc, A array -> acc, List.nth array i
+ | _, (S _ | L _) -> assert false
+
+ )
+ | ARRAY_SLICE (si) -> (
+ let ve = try List.hd vel with _ -> assert false in
+ match loop ve with
+ | acc, A array ->
+ let index_list = index_list_of_slice_info si in
+ let l = List.map (fun i -> List.nth array i) index_list in
+ acc, A l
+ | _, (S _ | L _) -> assert false
+ )
+ | VAR_REF id -> (
+ try
+ let vi = UglyStuff.var_info_of_ident id_solver id lxm in
+ (acc, gen_var_trees (make_val_exp nenv lxm vi) "" vi.var_type_eff)
+ with _ ->
+ let msg =
+ "\n*** during Array expansion: '"^
+ (id)^
+ "': Unknown variable.\n"^
+ "*** Current variables are: "^
+ (Hashtbl.fold
+ (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
+ nenv.lenv_vars "")
+ in
+ raise (Errors.Compile_error(lxm, msg))
+ )
+ | CONST_REF idl -> (
+ try
+ let const = UglyStuff.const_eff_of_item_key id_solver idl lxm in
+ let s, ve_const =
+ UnifyClock.const_to_val_eff lxm true UnifyClock.empty_subst const
+ in
+ let ve_const,acc =
+ match ve_const.ve_core with
+ | CallByPosLic ({it=CONST_REF _},_) ->
+ (* in order to avoid a potential infinite loop *)
+ (ve_const, acc)
+
+ | _ -> expand_val_exp nenv id_solver acc ve_const
+ in (acc, L (ve_const))
+ with _ ->
+ let msg =
+ "\n*** during Array expansion: '"^
+ (Ident.string_of_long idl)^
+ "': Unknown variable.\n"^
+ "*** Current variables are: "^
+ (Hashtbl.fold
+ (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
+ nenv.lenv_vars "")
+ in
+ raise (Errors.Compile_error(lxm, msg))
+ )
+ | WITH(_) | HAT(_) | CONCAT | ARRAY(_)
+ | PREDEF_CALL _ | CALL _ | MERGE _
+ | PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE -> (
+ (* Create a new loc var to alias such expressions *)
let acc, nloc = make_new_loc nenv id_solver lxm acc ve in
- acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
-
+ acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
+ )
+ )
+ | CallByNameLic(by_name_op, fl) ->
+ let lxm = by_name_op.src in
+ let acc, nloc = make_new_loc nenv id_solver lxm acc ve in
+ acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
+
and (break_tuple : Lxm.t -> left list -> val_exp -> Lic.eq_info srcflagged list) =
fun lxm left_list ve ->
if not !Global.ec then
[{ src = lxm ; it = (left_list, ve) }]
else
(* we only need to break tuples in this mode ...
- Note that this work only if the node expansion has already been done!
- (otherwise, we would not have the same number of items in the left and
- in the rigth part)
+ Note that this work only if the node expansion has already been done!
+ (otherwise, we would not have the same number of items in the left and
+ in the rigth part)
*)
let rec aux ve = (* flatten val exp*)
- match ve.ve_core with
- | CallByPosLic ({it= TUPLE}, OperLic vel) -> List.flatten (List.map aux vel)
- | CallByPosLic (unop, OperLic [ve1]) ->
- let ve1l = aux ve1 in
- List.map
- (fun ve1 -> { ve1 with ve_core = CallByPosLic (unop, OperLic [ve1])} )
- ve1l
- | CallByPosLic (binop, OperLic [ve1;ve2]) ->
- let ve1l, ve2l = aux ve1, aux ve2 in
- if (List.length ve1l <> List.length ve2l) then
- let vel2str vel =
- (String.concat ", " (List.map LicDump.string_of_val_exp_eff vel))
- in
- let msg =
- "*** error expression " ^ (LicDump.string_of_val_exp_eff ve) ^
- "\n cannot be broken \n" ^(vel2str ve1l) ^
- " should have the same arity as\n"^(vel2str ve2l) ^ "\n"
- in
- raise (Errors.Compile_error(lxm, msg))
- else
- List.map2
- (fun ve1 ve2 ->
- { ve with ve_core = CallByPosLic (binop, OperLic [ve1;ve2])})
- ve1l
- ve2l
-
- | CallByPosLic ({it= PREDEF_CALL(IF_n,[]); src=lxm}, OperLic [cond; ve1; ve2]) ->
-
- let ve1l, ve2l = aux ve1, aux ve2 in
- if (List.length ve1l <> List.length ve2l) then
- let vel2str vel =
- (String.concat ", " (List.map LicDump.string_of_val_exp_eff vel))
- in
- let msg =
- "*** error expression " ^ (LicDump.string_of_val_exp_eff ve) ^
- "\n cannot be broken \n" ^(vel2str ve1l) ^
- " should have the same arity as\n"^(vel2str ve2l) ^ "\n"
- in
- raise (Errors.Compile_error(lxm, msg))
- else
- List.map2
- (fun ve1 ve2 ->
- { ve with ve_core =
- CallByPosLic ({it= PREDEF_CALL(IF_n,[]); src=lxm},
- OperLic [cond;ve1;ve2])}
- )
- ve1l
- ve2l
-
- | _ -> [ve]
+ match ve.ve_core with
+ | CallByPosLic ({it= TUPLE}, OperLic vel) -> List.flatten (List.map aux vel)
+ | CallByPosLic (unop, OperLic [ve1]) ->
+ let ve1l = aux ve1 in
+ List.map
+ (fun ve1 -> { ve1 with ve_core = CallByPosLic (unop, OperLic [ve1])} )
+ ve1l
+ | CallByPosLic (binop, OperLic [ve1;ve2]) ->
+ let ve1l, ve2l = aux ve1, aux ve2 in
+ if (List.length ve1l <> List.length ve2l) then
+ let vel2str vel =
+ (String.concat ", " (List.map LicDump.string_of_val_exp_eff vel))
+ in
+ let msg =
+ "*** error expression " ^ (LicDump.string_of_val_exp_eff ve) ^
+ "\n cannot be broken \n" ^(vel2str ve1l) ^
+ " should have the same arity as\n"^(vel2str ve2l) ^ "\n"
+ in
+ raise (Errors.Compile_error(lxm, msg))
+ else
+ List.map2
+ (fun ve1 ve2 ->
+ { ve with ve_core = CallByPosLic (binop, OperLic [ve1;ve2])})
+ ve1l
+ ve2l
+
+ | CallByPosLic ({it= PREDEF_CALL(IF_n,[]); src=lxm}, OperLic [cond; ve1; ve2]) ->
+
+ let ve1l, ve2l = aux ve1, aux ve2 in
+ if (List.length ve1l <> List.length ve2l) then
+ let vel2str vel =
+ (String.concat ", " (List.map LicDump.string_of_val_exp_eff vel))
+ in
+ let msg =
+ "*** error expression " ^ (LicDump.string_of_val_exp_eff ve) ^
+ "\n cannot be broken \n" ^(vel2str ve1l) ^
+ " should have the same arity as\n"^(vel2str ve2l) ^ "\n"
+ in
+ raise (Errors.Compile_error(lxm, msg))
+ else
+ List.map2
+ (fun ve1 ve2 ->
+ { ve with ve_core =
+ CallByPosLic ({it= PREDEF_CALL(IF_n,[]); src=lxm},
+ OperLic [cond;ve1;ve2])}
+ )
+ ve1l
+ ve2l
+
+ | _ -> [ve]
in
let vel = aux ve in
- if (List.length vel <> List.length left_list) then
- (* migth occur for generic nodes, that needs to be compiled,
- but that will not be dumped. *)
- [{ src = lxm ; it = (left_list, ve) }]
- else
- List.map2
- (fun l ve ->
- let clk = [snd (Lic.var_info_of_left l).var_clock_eff] in
+ if (List.length vel <> List.length left_list) then
+ (* migth occur for generic nodes, that needs to be compiled,
+ but that will not be dumped. *)
+ [{ src = lxm ; it = (left_list, ve) }]
+ else
+ List.map2
+ (fun l ve ->
+ let clk = [snd (Lic.var_info_of_left l).var_clock_eff] in
{ src = lxm ;
- it = ([l], { ve with ve_typ = [Lic.type_of_left l] ; ve_clk = clk}) }
- )
- left_list
- vel
+ it = ([l], { ve with ve_typ = [Lic.type_of_left l] ; ve_clk = clk}) }
+ )
+ left_list
+ vel
and (expand_eq :
Lic.local_env -> Lic.id_solver -> acc -> Lic.eq_info srcflagged -> acc) =
@@ -410,165 +411,166 @@ and (expand_eq :
let ve,acc = expand_val_exp nenv id_solver acc ve in
let eq_list = break_tuple lxm_eq left_list ve in
let (asserts, eqs, locs) = acc in
- (asserts, eq_list@eqs, locs)
+ (asserts, eq_list@eqs, locs)
and expand_val_exp_list n_env id_solver acc vel =
List.fold_left
(fun (vel,acc) ve ->
- let ve,acc = expand_val_exp n_env id_solver acc ve in
- ve::vel, acc
+ let ve,acc = expand_val_exp n_env id_solver acc ve in
+ ve::vel, acc
)
([],acc) (List.rev vel)
and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
- val_exp * acc) =
+ val_exp * acc) =
fun n_env id_solver acc ve ->
match ve.ve_core with
| CallByPosLic (by_pos_op, OperLic vel) ->
- let lxm = by_pos_op.src in
- let by_pos_op = by_pos_op.it in
- let by_pos_op, acc, vel =
- match by_pos_op with
- | WITH(ve) ->
- let ve, acc = expand_val_exp n_env id_solver acc ve in
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
- WITH(ve), acc, vel
- | HAT(i,ve) ->
- let ve, acc = expand_val_exp n_env id_solver acc ve in
- let rec unfold cpt =
- if cpt = 0 then [] else ve::(unfold (cpt-1))
- in
- TUPLE, acc, unfold i
- | ARRAY(vel) ->
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
- TUPLE, acc, vel
-
- | CONCAT | PREDEF_CALL _ | CALL _ | MERGE _
- | PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE
- ->
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
- by_pos_op, acc, vel
-
- | STRUCT_ACCESS (_)
- | ARRAY_ACCES (_)
- | ARRAY_SLICE (_)
- | VAR_REF _
- | CONST_REF _ ->
- let acc, vt = try var_trees_of_val_exp n_env id_solver acc ve
- with (Not_found | Failure _) ->
- assert false (* just a defense against nth and assoc *)
- in
- TUPLE, acc, flatten_var_tree vt
-
- in
- let newve = CallByPosLic(Lxm.flagit by_pos_op lxm, OperLic vel) in
- let newve = { ve with ve_core = newve } in
- (* if newve.core <> ve.core then ( *)
- (* EvalClock.copy newve ve *)
- (* ); *)
- newve, acc
-
+ let lxm = by_pos_op.src in
+ let by_pos_op = by_pos_op.it in
+ let by_pos_op, acc, vel =
+ match by_pos_op with
+ | WITH(ve) ->
+ let ve, acc = expand_val_exp n_env id_solver acc ve in
+ let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ WITH(ve), acc, vel
+ | HAT(i,ve) ->
+ let ve, acc = expand_val_exp n_env id_solver acc ve in
+ let rec unfold cpt =
+ if cpt = 0 then [] else ve::(unfold (cpt-1))
+ in
+ TUPLE, acc, unfold i
+ | ARRAY(vel) ->
+ let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ TUPLE, acc, vel
+
+ | CONCAT | PREDEF_CALL _ | CALL _ | MERGE _
+ | PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE
+ ->
+ let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ by_pos_op, acc, vel
+
+ | STRUCT_ACCESS (_)
+ | ARRAY_ACCES (_)
+ | ARRAY_SLICE (_)
+ | VAR_REF _
+ | CONST_REF _ ->
+ let acc, vt = try var_trees_of_val_exp n_env id_solver acc ve
+ with (Not_found | Failure _) ->
+ assert false (* just a defense against nth and assoc *)
+ in
+ TUPLE, acc, flatten_var_tree vt
+
+ in
+ let newve = CallByPosLic(Lxm.flagit by_pos_op lxm, OperLic vel) in
+ let newve = { ve with ve_core = newve } in
+ (* if newve.core <> ve.core then ( *)
+ (* EvalClock.copy newve ve *)
+ (* ); *)
+ newve, acc
+
| CallByNameLic(by_name_op, fl_val) ->
- (* we want to print fields in the order of the type.
- Moreover, we have to deal with default value.
- *)
- let teff = ve.ve_typ in
- match teff with
- | [Struct_type_eff(_,fl)] ->
- let lxm = by_name_op.src in
- let vel,acc =
- List.fold_left
- (fun (vel,acc) (id,(_,const_opt)) ->
- try
- let _,ve = List.find (fun (id2,_) -> id2.it = id) fl_val in
- let ve,acc = expand_val_exp n_env id_solver acc ve in
- ve::vel, acc
- with Not_found ->
- match const_opt with
- | None -> assert false
- (* ougth to have been checked before *)
- | Some const ->
- let s, ve_const = (* XXX *)
- UnifyClock.const_to_val_eff lxm true
- UnifyClock.empty_subst const
- in
- let ve_const,acc=
- expand_val_exp n_env id_solver acc ve_const
- in
- ve_const::vel,acc
- )
- ([],acc)
- fl
- in
- let newve = {
- ve_typ = ve.ve_typ;
- ve_clk = ve.ve_clk;
- ve_core=CallByPosLic({ src=lxm ; it=TUPLE }, OperLic (List.rev vel))
- }
- in
- (* if newve.core <> ve.core then ( *)
- (* EvalClock.copy newve ve *)
- (* ); *)
- newve, acc
-
- | _ -> assert false
+ (* we want to print fields in the order of the type.
+ Moreover, we have to deal with default value.
+ *)
+ let teff = ve.ve_typ in
+ match teff with
+ | [Struct_type_eff(_,fl)] ->
+ let lxm = by_name_op.src in
+ let vel,acc =
+ List.fold_left
+ (fun (vel,acc) (id,(_,const_opt)) ->
+ try
+ let _,ve = List.find (fun (id2,_) -> id2.it = id) fl_val in
+ let ve,acc = expand_val_exp n_env id_solver acc ve in
+ ve::vel, acc
+ with Not_found ->
+ match const_opt with
+ | None -> assert false
+ (* ougth to have been checked before *)
+ | Some const ->
+ let s, ve_const = (* XXX *)
+ UnifyClock.const_to_val_eff lxm true
+ UnifyClock.empty_subst const
+ in
+ let ve_const,acc=
+ expand_val_exp n_env id_solver acc ve_const
+ in
+ ve_const::vel,acc
+ )
+ ([],acc)
+ fl
+ in
+ let newve = {
+ ve_typ = ve.ve_typ;
+ ve_clk = ve.ve_clk;
+ ve_core=CallByPosLic({ src=lxm ; it=TUPLE }, OperLic (List.rev vel))
+ }
+ in
+ (* if newve.core <> ve.core then ( *)
+ (* EvalClock.copy newve ve *)
+ (* ); *)
+ newve, acc
+
+ | _ -> assert false
and (expand_val_exp_flag: Lic.local_env -> Lic.id_solver -> acc ->
- val_exp srcflagged -> val_exp srcflagged * acc) =
+ val_exp srcflagged -> val_exp srcflagged * acc) =
fun n_env id_solver acc { src = lxm ; it = ve } ->
let ve,acc = expand_val_exp n_env id_solver acc ve in
- { src = lxm ; it = ve }, acc
+ { src = lxm ; it = ve }, acc
and (expand_assert:
Lic.local_env -> Lic.id_solver -> acc -> val_exp srcflagged -> acc) =
fun n_env id_solver acc ve ->
let (ve, (asserts, eqs, locs)) = expand_val_exp_flag n_env id_solver acc ve in
- (ve::asserts, eqs, locs)
+ (ve::asserts, eqs, locs)
and (expand_var_info: Lic.local_env -> Lic.id_solver -> var_info list * acc ->
- var_info -> var_info list * acc) =
+ var_info -> var_info list * acc) =
fun nenv id_solver (vil, acc) vi ->
let rec aux teff =
match teff with
| Abstract_type_eff (_, teff) -> aux teff
| TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error "L2lExpandArrays.expand_var_info" "should not have been called for a any(num) var";
- assert false
+ Errors.print_internal_error
+ "L2lExpandArrays.expand_var_info" "should not have been called for a any(num) var";
+ assert false
| Struct_type_eff (name, fl) ->
- List.fold_left
- (fun (vil,acc) (fn, (ft,_const_opt)) ->
- let new_var = clone_var nenv vi ("_" ^ Ident.to_string fn) ft in
- let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
- if new_vil = new_var::vil then (
- (* [new_var] type is not made of structure *)
- assert (is_a_basic_type ft);
- Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
- new_vil, new_acc
- )
- (vil, acc)
- fl
+ List.fold_left
+ (fun (vil,acc) (fn, (ft,_const_opt)) ->
+ let new_var = clone_var nenv vi ("_" ^ Ident.to_string fn) ft in
+ let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
+ if new_vil = new_var::vil then (
+ (* [new_var] type is not made of structure *)
+ assert (is_a_basic_type ft);
+ Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
+ new_vil, new_acc
+ )
+ (vil, acc)
+ fl
| Array_type_eff(at,size) ->
- let rec aux i (vil,acc) =
- if i=size then (vil,acc) else
- let new_var = clone_var nenv vi ("_" ^ soi i) at in
- let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
- if new_vil = new_var::vil then (
- (* [new_var] type is not made of structure *)
- assert (is_a_basic_type at);
- Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
- aux (i+1) (new_vil, new_acc)
- in
- aux 0 (vil,acc)
+ let rec aux i (vil,acc) =
+ if i=size then (vil,acc) else
+ let new_var = clone_var nenv vi ("_" ^ soi i) at in
+ let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
+ if new_vil = new_var::vil then (
+ (* [new_var] type is not made of structure *)
+ assert (is_a_basic_type at);
+ Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
+ aux (i+1) (new_vil, new_acc)
+ in
+ aux 0 (vil,acc)
| External_type_eff(_)
| Enum_type_eff (_, _)
| Real_type_eff
| Int_type_eff
| Bool_type_eff ->
- vi::vil, acc
+ vi::vil, acc
in
- aux vi.var_type_eff
+ aux vi.var_type_eff
let rec (node : Lic.id_solver -> Lic.local_env -> Lic.node_exp -> Lic.node_exp) =
fun is n_env n ->
@@ -606,3 +608,19 @@ let rec (node : Lic.id_solver -> Lic.local_env -> Lic.node_exp -> Lic.node_exp)
outlist_eff = List.rev outlist;
}
+
+(* exported *)
+let rec (doit : Lic.id_solver -> Lic.local_env -> LicPrg.t -> LicPrg.t) =
+ fun id_solver lenv inprg ->
+ let outprg = LicPrg.empty in
+ (** types and constants do not change *)
+ let outprg = LicPrg.fold_types LicPrg.add_type inprg outprg in
+ let outprg = LicPrg.fold_consts LicPrg.add_const inprg outprg in
+ (** transform nodes *)
+ let rec (do_node : Lic.node_key -> Lic.node_exp -> LicPrg.t -> LicPrg.t) =
+ fun nk ne outprg ->
+ let ne = node id_solver lenv ne in
+ LicPrg.add_node nk ne outprg
+ in
+ let outprg = LicPrg.fold_nodes do_node inprg outprg in
+ outprg
diff --git a/src/l2lExpandArrays.mli b/src/l2lExpandArrays.mli
index 78d25c94aa9a76f1d1e626f85d3bcc6275c55f76..d52a875a0e62f021792419555975b0d9f8b5479a 100644
--- a/src/l2lExpandArrays.mli
+++ b/src/l2lExpandArrays.mli
@@ -1,5 +1,8 @@
-(* Time-stamp: <modified the 12/12/2012 (at 17:40) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/12/2012 (at 15:58) by Erwan Jahier> *)
(** Expand strutures and arrays *)
-val node : Lic.id_solver -> Lic.local_env -> Lic.node_exp -> Lic.node_exp
+
+val doit : Lic.id_solver -> Lic.local_env -> LicPrg.t -> LicPrg.t
+
+
diff --git a/src/lic.ml b/src/lic.ml
index 7be9f6dc6a375f95fd4e130af9a10e42519446cc..98f058321a045b72a3aa5e0e803f1f7dae3a4412 100644
--- a/src/lic.ml
+++ b/src/lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:32) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/12/2012 (at 16:16) by Erwan Jahier> *)
(** Define the Data Structure representing Compiled programs. *)
@@ -409,7 +409,7 @@ type local_env = {
lenv_vars : (Ident.t, var_info) Hashtbl.t ;
}
-(* Just to group those 3 ones *)
+(* Just to group those 2 ones *)
type node_env = {
local : local_env;
global: id_solver;
diff --git a/src/licTab.ml b/src/licTab.ml
index 27e3b0e0150d3ed781c75f8cc44e7ea423f8d9d8..a456b53774ef0e21b9ad2a27f84474f47a1a5d35 100644
--- a/src/licTab.ml
+++ b/src/licTab.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:32) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/12/2012 (at 16:21) by Erwan Jahier> *)
open Lxm
@@ -1352,7 +1352,7 @@ let compile_all_nodes pack_name this id ni_f =
taken into account
*)
-let to_lic (this:t) : LicPrg.t =
+let to_lic_prg (this:t) : LicPrg.t =
(* normally, only checked and correct programs are lic'ified *)
let unflag = function Checked x -> x | _ -> assert false in
let add_item add_x k v prg =
diff --git a/src/licTab.mli b/src/licTab.mli
index 7319d5036f1e8a6960eb46b23e287422f7eb9cef..fcce569d080b6b4b3281064a8de3e692f6720018 100644
--- a/src/licTab.mli
+++ b/src/licTab.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 12/12/2012 (at 17:12) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/12/2012 (at 16:21) by Erwan Jahier> *)
(* nb: compiling = type checking + constant evaluation *)
@@ -24,4 +24,4 @@ val compile_node : t -> Ident.idref -> t
val compile_all : t -> t
(** Just a simple change of data structure (from imperative tables to functional maps) *)
-val to_lic : t -> LicPrg.t
+val to_lic_prg : t -> LicPrg.t
diff --git a/src/uglyStuff.ml b/src/uglyStuff.ml
index 8780da3338350ae8698eeb7676592f86ad9da68c..3a9c6fac1d43eff89e8cfbf7377c68063693c981 100644
--- a/src/uglyStuff.ml
+++ b/src/uglyStuff.ml
@@ -13,24 +13,24 @@ infos déjà compilées, alors que c'est pas fait pour...
- Y'a un probleme de gestion d'environnement a revoir ...
*)
let node_exp_of_node_key
- (id_solver: Lic.id_solver)
- (node_key: Lic.node_key)
- (lxm : Lxm.t)
-: Lic.node_exp =
- let (id, sargs) = node_key in
- id_solver.Lic.id2node (Ident.idref_of_long id) sargs lxm
+ (id_solver: Lic.id_solver)
+ (node_key: Lic.node_key)
+ (lxm : Lxm.t)
+ : Lic.node_exp =
+ let (id, sargs) = node_key in
+ id_solver.Lic.id2node (Ident.idref_of_long id) sargs lxm
let var_info_of_ident
- (id_solver: Lic.id_solver)
- (id: Ident.t)
- (lxm : Lxm.t)
-: Lic.var_info =
- id_solver.Lic.id2var (Ident.idref_of_id id) lxm
+ (id_solver: Lic.id_solver)
+ (id: Ident.t)
+ (lxm : Lxm.t)
+ : Lic.var_info =
+ id_solver.Lic.id2var (Ident.idref_of_id id) lxm
let const_eff_of_item_key
- (id_solver: Lic.id_solver)
- (id: Lic.item_key)
- (lxm : Lxm.t)
-: Lic.const =
- id_solver.Lic.id2const (Ident.idref_of_long id) lxm
+ (id_solver: Lic.id_solver)
+ (id: Lic.item_key)
+ (lxm : Lxm.t)
+ : Lic.const =
+ id_solver.Lic.id2const (Ident.idref_of_long id) lxm
diff --git a/todo.org b/todo.org
index 8c180a21238b3dd788de2098cec15dbe5874b57f..e8e61671915108900a98bab70f33ddd2f0a74682 100644
--- a/todo.org
+++ b/todo.org
@@ -2,30 +2,16 @@
#+CATEGORY: lv6
-
* Urgent
-**
-
-** TODO Mettre à jour le tout nouveau file:README.org wrt src
- SCHEDULED: <2012-12-10 Mon>
- - State "TODO" from "" [2012-12-10 Mon 17:02]
-
-** TODO Renommer tous les modules et faire du ménage
- SCHEDULED: <2012-12-10 Mon>
- - State "TODO" from "" [2012-12-10 Mon 16:55]
-
** TODO rebrancher le nodeExpand.ml et structArrayExpand.ml
SCHEDULED: <2012-12-10 Mon>
- State "TODO" from "" [2012-12-10 Mon 16:55]
-file:~/lus2lic/src/nodesExpand.ml
-
-file:~/lus2lic/src/structArrayExpand.mli
-
-
-Pascal les a débranché lors de son ménage d'été.
+file:src/l2lExpandNodes.mli
+file:src/l2lExpandArrays.mli
+que Pascal les a débranché lors de son ménage d'été.
** TODO Refaire marcher les tests de non-reg qui sont cassés