From f2b27b8932db9221ed890b6c8c6af68b5abf40c4 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Thu, 26 Jun 2014 17:56:33 +0200
Subject: [PATCH] Change back some of the changes done in
716f0d5b5507bb9c98348004357b1ffa4ee47ce7 where I've removed the handling of
polymorphism.
---
Makefile | 4 +---
src/lic2soc.ml | 6 +++---
src/soc.ml | 23 ++++++++++++++++++---
src/soc2c.ml | 8 ++++----
src/soc2cIdent.ml | 4 +---
src/soc2cUtil.ml | 4 ++--
src/socExec.ml | 6 +++---
src/socExecValue.ml | 4 ++--
src/socPredef.ml | 50 ++++++++++++++++++++++-----------------------
src/socVar.ml | 6 +++---
test/Makefile | 2 ++
test/lus2lic.sum | 20 ++++++++++--------
test/lus2lic.time | 2 +-
13 files changed, 78 insertions(+), 61 deletions(-)
diff --git a/Makefile b/Makefile
index 297fbbe0..b9692455 100644
--- a/Makefile
+++ b/Makefile
@@ -44,9 +44,7 @@ TESTDIR=./test
test_nc:
cd $(TESTDIR) ; make test ; cd $(curdir)
-# ltop is necessary because it is used for the non-reg test and it depends on some src here...
-# When I use rdbg -lurette, I can throw that ltop dep away
-test: ltop
+test:
cd $(TESTDIR) ; make ; make time
cd $(curdir)
diff --git a/src/lic2soc.ml b/src/lic2soc.ml
index 38ba7ff0..171f48c7 100644
--- a/src/lic2soc.ml
+++ b/src/lic2soc.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 25/06/2014 (at 16:34) by Erwan Jahier> *)
+(** Time-stamp: <modified the 26/06/2014 (at 17:44) by Erwan Jahier> *)
(* XXX ce module est mal écrit. A reprendre. (R1) *)
@@ -52,9 +52,9 @@ let rec lic_to_data_type: (Lic.type_ -> Data.t) =
)
| Lic.Array_type_eff(ty,i) -> Data.Array(lic_to_data_type ty,i)
| Lic.Abstract_type_eff (id, t) -> Data.Alias(Ident.string_of_long id,lic_to_data_type t)
- | Lic.TypeVar Lic.Any
+ | Lic.TypeVar Lic.Any -> Data.Alpha 0
| Lic.TypeVar Lic.AnyNum ->
- (* For some reasons, L2lRmPoly did not manage to resolve all the polymorphism.
+ (* For some reasons, L2lRmPoly did not manage to resolve all the overloeding.
In that case, we stop.
nb : i raise an exception here because I've got no Lxm.t to use
diff --git a/src/soc.ml b/src/soc.ml
index 8cf44eb7..a5ff10d4 100644
--- a/src/soc.ml
+++ b/src/soc.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 14:21) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:45) by Erwan Jahier> *)
(** Synchronous Object Component *)
@@ -91,11 +91,28 @@ type t = {
(* Do this soc have a memory (pre, fby) + its type *)
}
-
+let (compare_soc_key : key -> key -> int) =
+ fun (id1, tl1, si1) (id2, tl2, si2) ->
+ let rec unifiable tl1 tl2 =
+ (* Very simple version that is correct only for keys that
+ contain at most 1 polymorphic var, which is currently the
+ case for v6 programs *)
+ match tl1,tl2 with
+ | [],[] -> true
+ | _::tl1, Data.Alpha(_)::tl2
+ | Data.Alpha(_)::tl1, _::tl2 -> unifiable tl1 tl2
+ | t1::tl1, t2::tl2 -> t1=t2 && unifiable tl1 tl2
+ | _,_ -> false
+ in
+ if unifiable tl1 tl2
+ then compare (id1, si1) (id2, si2)
+ else compare (id1, tl1, si1) (id2, tl2, si2)
+
+(* SocKeyMap ? *)
module SocMap = Map.Make(
struct
type t = key
- let compare = compare
+ let compare = compare_soc_key
end
)
diff --git a/src/soc2c.ml b/src/soc2c.ml
index ce02b5c6..c2c0f8f3 100644
--- a/src/soc2c.ml
+++ b/src/soc2c.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 14:43) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:36) by Erwan Jahier> *)
(* let put (os: out_channel) (fmt:('a, unit, string, unit) format4) : 'a = *)
@@ -28,7 +28,7 @@ let rec (type_to_string : Data.t -> string -> string) =
| Enum (s, sl) -> finish acc (id2s s ^" "^n)
| Struct (sid,_) -> finish acc ((id2s sid)^" "^n)
| Array (ty, sz) -> aux (sz::acc) ty n
-(* | Alpha nb -> finish acc ("alpha_"^(string_of_int nb)^" "^n) *)
+ | Alpha nb -> finish acc ("alpha_"^(string_of_int nb)^" "^n)
| Alias(a,_) -> finish acc (a^" "^n)
in
aux [] v n
@@ -44,7 +44,7 @@ let rec (type_to_string2 : Data.t -> string) =
| Enum (s, sl) -> id2s s
| Struct (sid,_) -> (id2s sid)
| Array (ty, sz) -> Printf.sprintf "%s_%d" (type_to_string2 ty) sz
-(* | Alpha nb -> "alpha_"^(string_of_int nb) *)
+ | Alpha nb -> "alpha_"^(string_of_int nb)
| Alias(n,_) -> n
in
str
@@ -267,7 +267,7 @@ let (type_to_format_string : Data.t -> string) =
| Enum (s, sl) -> "%d"
| Struct (sid,_) -> "%s"
| Array (ty, sz) -> "%s"
-(* | Alpha nb -> assert false *)
+ | Alpha nb -> assert false
diff --git a/src/soc2cIdent.ml b/src/soc2cIdent.ml
index a8e716b6..f1cb6bb8 100644
--- a/src/soc2cIdent.ml
+++ b/src/soc2cIdent.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 14:38) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:37) by Erwan Jahier> *)
let colcol = Str.regexp "::"
let id2s id = (* XXX Refuser les noms de module à la con plutot *)
@@ -28,7 +28,6 @@ let rec (type_to_short_string : Data.t -> string) =
| Data.Struct (sid,_) -> sid
| Data.Array (ty, sz) -> Printf.sprintf "%sp%d" (type_to_short_string ty) sz
| Data.Alias(n,_) -> n
-(*
| Data.Alpha nb ->
(* On génère des "types" à la Caml : 'a, 'b, 'c, etc. *)
let a_value = Char.code('a') in
@@ -40,7 +39,6 @@ let rec (type_to_short_string : Data.t -> string) =
("a" ^ (string_of_int nb))
in
str
-*)
in
str
diff --git a/src/soc2cUtil.ml b/src/soc2cUtil.ml
index e31b8318..b2697baf 100644
--- a/src/soc2cUtil.ml
+++ b/src/soc2cUtil.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 14:38) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:37) by Erwan Jahier> *)
(* exported *)
@@ -10,7 +10,7 @@ let rec (gen_assign : Data.t -> string -> string -> string -> string) =
| Struct(_) (* should I rather use memcpy for struct? *)
| Bool | Int | Real ->
Printf.sprintf " %s = %s;\n" vi vo
-(* | Alpha(_) (* dead code ? *) *)
+ | Alpha(_) (* dead code ? *)
| Array(_) ->
Printf.sprintf " memcpy(%s, %s, %s);\n" vi vo size
diff --git a/src/socExec.ml b/src/socExec.ml
index 6815febb..1f15ee5c 100644
--- a/src/socExec.ml
+++ b/src/socExec.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 20/06/2014 (at 11:29) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 09:58) by Erwan Jahier> *)
open Soc
open Data
@@ -76,7 +76,7 @@ let rec (soc_step : Soc.step_method -> Soc.tbl -> Soc.t -> SocExecValue.ctx
let ctx = do_step inst_name node_step ctx soc_tbl node_soc vel_in vel_out in
{ ctx with cpath=path_saved }
else
- let first_step = Var ("$first_step",Bool) in
+ let first_step = Var ("_memory",Bool) in
let v = get_value ctx first_step in
if v = U || v = B true then
(* We are on the first step of node_soc;
@@ -88,7 +88,7 @@ let rec (soc_step : Soc.step_method -> Soc.tbl -> Soc.t -> SocExecValue.ctx
and the output will keep their previous value. *)
{ ctx with cpath=path_saved }
in
- let ctx = { ctx with s = sadd ctx.s ("$first_step"::ctx.cpath) (B false) } in
+ let ctx = { ctx with s = sadd ctx.s ("_memory"::ctx.cpath) (B false) } in
ctx
)
| Iterator(iter, node_sk, n) ->
diff --git a/src/socExecValue.ml b/src/socExecValue.ml
index f079824d..8eb3c84f 100644
--- a/src/socExecValue.ml
+++ b/src/socExecValue.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 15:34) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:37) by Erwan Jahier> *)
let dbg = (Verbose.get_flag "exec")
@@ -259,7 +259,7 @@ let rec (get_value : ctx -> var_expr -> Data.v) =
| Const(id, Bool) -> assert false
| Const(id, Extern _) -> assert false
| Const(id, Alias _) -> assert false
-(* | Const(id,Alpha _) -> assert false (* todo *) *)
+ | Const(id,Alpha _) -> assert false (* todo *)
| Field(ve,fn,t) ->
let s = get_value ctx ve in
(match s with
diff --git a/src/socPredef.ml b/src/socPredef.ml
index 6d4adcdb..32b2e8f4 100644
--- a/src/socPredef.ml
+++ b/src/socPredef.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 14:59) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:37) by Erwan Jahier> *)
(** Synchronous Object Code for Predefined operators. *)
@@ -300,7 +300,7 @@ let instanciate_soc: Soc.t -> Data.t -> Soc.t =
fun c concrete_type ->
let rec instanciate_type vt =
match vt with
-(* | Alpha _ -> concrete_type *)
+ | Alpha _ -> concrete_type
| Struct(sn, fl) ->
Struct(sn, List.map (fun (id,vt) -> (id,instanciate_type vt)) fl)
| Array(vt,i) -> Array(instanciate_type vt,i)
@@ -317,12 +317,12 @@ let instanciate_soc: Soc.t -> Data.t -> Soc.t =
let new_instances =
List.map (fun (id,sk) -> (id,instanciate_key sk)) c.instances
in
- {
- c with
- key = new_key;
- profile = new_profile;
- instances = new_instances;
- }
+ {
+ c with
+ key = new_key;
+ profile = new_profile;
+ instances = new_instances;
+ }
(*
@@ -450,25 +450,25 @@ let make_hat_soc: int -> Data.t -> Soc.t =
fun i t ->
let array_type =
match t with
-(* | Data.Alpha _ -> assert false *)
+ | Data.Alpha _ -> assert false
| t -> Data.Array(t,i)
in
- {
- key = ("Lustre::hat", [t;array_type], Nomore);
- profile = ([("x", t)], ["z", array_type]);
- instances = [];
- step = [
- {
- name = "step";
- lxm = Lxm.dummy "predef hat soc";
- idx_ins = [0];
- idx_outs = [0];
- impl = Predef;
- };
- ];
- precedences = [];
- have_mem = None;
- }
+ {
+ key = ("Lustre::hat", [t;array_type], Nomore);
+ profile = ([("x", t)], ["z", array_type]);
+ instances = [];
+ step = [
+ {
+ name = "step";
+ lxm = Lxm.dummy "predef hat soc";
+ idx_ins = [0];
+ idx_outs = [0];
+ impl = Predef;
+ };
+ ];
+ precedences = [];
+ have_mem = None;
+ }
let output_type_of_op op tl =
match op with
diff --git a/src/socVar.ml b/src/socVar.ml
index 4dbc538e..4607f11e 100644
--- a/src/socVar.ml
+++ b/src/socVar.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 25/06/2014 (at 15:02) by Erwan Jahier> *)
+(* Time-stamp: <modified the 26/06/2014 (at 17:43) by Erwan Jahier> *)
open Data
@@ -25,7 +25,7 @@ and expand_var enum_flag c_access var = match var with
(List.map (fun (fn,t) -> vn^(if c_access then "." else "_")^fn,t ) fl)
| (vn,Extern id) -> [var]
| (vn,Alias(n, t)) -> expand_var enum_flag c_access (vn,t)
-(* | (vn,Alpha _) -> assert false (* should not occur *) *)
+ | (vn,Alpha _) -> assert false (* should not occur *)
let (int_to_enum : Data.v -> Soc.ident list -> Data.v) =
fun v el ->
@@ -102,7 +102,7 @@ let (unexpand_profile : sl -> Soc.var list -> sl) =
aux sl_done sl_todo vl
| _, (vn,Extern id)::_ -> assert false (* finish me! *)
-(* | _, (vn,Alpha _ )::_ -> assert false (* should not occur *) *)
+ | _, (vn,Alpha _ )::_ -> assert false (* should not occur *)
and (aux_field : sl * (ident * Data.v) list -> ident * Data.t -> sl * (ident * Data.v) list ) =
fun (sl_todo, fl) (fn, t) ->
diff --git a/test/Makefile b/test/Makefile
index 7e90af1a..5e136dce 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -8,6 +8,8 @@ OCAMLRUNPARAM=s=1M,i=32M,o=150
# to perform the test on the local machine rather than on $(TEST_MACHINE)
ltest: runtest lus2lic.diff lus2lic.time
+# ltop is necessary because it is used for the non-reg test and it depends on some src here...
+# When I use rdbg -lurette, I can throw that ltop dep away
ltop:
cd .. ; make ltop
diff --git a/test/lus2lic.sum b/test/lus2lic.sum
index d45b1147..ca025fce 100644
--- a/test/lus2lic.sum
+++ b/test/lus2lic.sum
@@ -1,4 +1,4 @@
-Test Run By jahier on Thu Jun 26 16:51:39 2014
+Test Run By jahier on Thu Jun 26 17:47:00 2014
Native configuration is i686-pc-linux-gnu
=== lus2lic tests ===
@@ -143,8 +143,8 @@ PASS: gcc dependeur_dependeur.c dependeur_dependeur_loop.c
PASS: ./lus2lic {-o /tmp/mappredef.lic should_work/mappredef.lus}
PASS: ./lus2lic {-ec -o /tmp/mappredef.ec should_work/mappredef.lus}
PASS: ./myec2c {-o /tmp/mappredef.c /tmp/mappredef.ec}
-FAIL: Try to compare lus2lic -exec and ecexe: ../utils/test_lus2lic_no_node should_work/mappredef.lus
-FAIL: Generate c code : ./lus2lic {-2c should_work/mappredef.lus -n mappredef}
+PASS: ../utils/test_lus2lic_no_node should_work/mappredef.lus
+PASS: ./lus2lic {-2c should_work/mappredef.lus -n mappredef}
FAIL: Check that the generated C code compiles : gcc mappredef_mappredef.c mappredef_mappredef_loop.c
PASS: ./lus2lic {-o /tmp/call06.lic should_work/call06.lus}
PASS: ./lus2lic {-ec -o /tmp/call06.ec should_work/call06.lus}
@@ -1397,9 +1397,9 @@ PASS: gcc func_with_body_func_with_body.c func_with_body_func_with_body_loop.c
PASS: ./lus2lic {-o /tmp/minus.lic should_work/minus.lus}
PASS: ./lus2lic {-ec -o /tmp/minus.ec should_work/minus.lus}
PASS: ./myec2c {-o /tmp/minus.c /tmp/minus.ec}
-FAIL: Try to compare lus2lic -exec and ecexe: ../utils/test_lus2lic_no_node should_work/minus.lus
-FAIL: Generate c code : ./lus2lic {-2c should_work/minus.lus -n minus}
-PASS: gcc minus_minus.c minus_minus_loop.c
+PASS: ../utils/test_lus2lic_no_node should_work/minus.lus
+PASS: ./lus2lic {-2c should_work/minus.lus -n minus}
+FAIL: Check that the generated C code compiles : gcc minus_minus.c minus_minus_loop.c
PASS: ./lus2lic {-o /tmp/remplissage-1.0.lic should_work/remplissage-1.0.lus}
PASS: ./lus2lic {-ec -o /tmp/remplissage-1.0.ec should_work/remplissage-1.0.lus}
PASS: ./myec2c {-o /tmp/remplissage-1.0.c /tmp/remplissage-1.0.ec}
@@ -1475,9 +1475,11 @@ XPASS: Test bad programs (semantics): lus2lic {-o /tmp/bug.lic should_fail/seman
=== lus2lic Summary ===
-# of expected passes 1285
-# of unexpected failures 120
+# of expected passes 1288
+# of unexpected failures 117
# of unexpected successes 21
# of expected failures 37
-testcase ./lus2lic.tests/non-reg.exp completed in 131 seconds
+testcase ./lus2lic.tests/non-reg.exp completed in 136 seconds
+testcase ./lus2lic.tests/progression.exp completed in 1 seconds
+testcase ./lus2lic.tests/non-reg.exp completed in 136 seconds
testcase ./lus2lic.tests/progression.exp completed in 1 seconds
diff --git a/test/lus2lic.time b/test/lus2lic.time
index 73ed2e9b..1aa21d49 100644
--- a/test/lus2lic.time
+++ b/test/lus2lic.time
@@ -1,2 +1,2 @@
-testcase ./lus2lic.tests/non-reg.exp completed in 131 seconds
+testcase ./lus2lic.tests/non-reg.exp completed in 136 seconds
testcase ./lus2lic.tests/progression.exp completed in 1 seconds
--
GitLab