diff --git a/AFAIRE b/AFAIRE
index 020aa118f6156f660992681bd76dfbaa857aba56..af7e376936510aedd623984038b560e73cf01bf5 100644
--- a/AFAIRE
+++ b/AFAIRE
@@ -1,3 +1,9 @@
+
+12/08/06
+bug
+./objlinux64/lus2lic test_static/cond01.lus -dbg lazyc
+
+
12/08/03
./objlinux/lus2lic test_static/predef01.lus
diff --git a/Makefile b/Makefile
index 62701d45a8844b75a681958a887a3e3900e21201..c9afa1570d955d0807f9f9463a2c04f2aa61ef91 100644
--- a/Makefile
+++ b/Makefile
@@ -72,13 +72,13 @@ SOURCES = \
$(OBJDIR)/syntaxTab.mli \
$(OBJDIR)/syntaxTab.ml \
$(OBJDIR)/uglyStuff.ml \
- $(OBJDIR)/builtIn.ml \
$(OBJDIR)/predefEvalType.mli \
$(OBJDIR)/predefEvalType.ml \
$(OBJDIR)/predefEvalConst.mli \
$(OBJDIR)/predefEvalConst.ml \
$(OBJDIR)/predefEvalClock.mli \
$(OBJDIR)/predefEvalClock.ml \
+ $(OBJDIR)/builtIn.ml \
$(OBJDIR)/evalConst.mli \
$(OBJDIR)/evalConst.ml \
$(OBJDIR)/evalType.mli \
diff --git a/src/builtIn.ml b/src/builtIn.ml
index 9055db3d4a5e679d34dac954e0b7f3f190bd84d5..ba04ce028a3f4ba9c8b2a1822a95c24c6de9a3cb 100644
--- a/src/builtIn.ml
+++ b/src/builtIn.ml
@@ -28,6 +28,16 @@ let get_node_and_int_const
let var_to_array (c:int) (vi: Eff.var_info) : Eff.var_info =
{ vi with var_type_eff = Array_type_eff(vi.var_type_eff,c) }
+(***
+MESSAGES D'ERREUR :
+Pour rester homogène, utiliser les fonctions de PredefEvalType:
+ raise_type_error (provided: string) (expect: string) (msg: string)
+ raise_arity_error (msg:string) (provided:int) (expect:int)
+*)
+let raise_type_error = PredefEvalType.raise_type_error
+let raise_arity_error = PredefEvalType.raise_arity_error
+exception EvalType_error = PredefEvalType.EvalType_error
+
(*
On a éventuellement besoin du node_exp des args
*)
@@ -41,9 +51,9 @@ let rec do_node
| ("Lustre", "map") -> do_map nk2nd nk lxm
| ("Lustre", "red")
| ("Lustre", "fill")
- | ("Lustre", "fillred") -> assert false (*do_fillred sargs *)
- | ("Lustre", "boolred") -> assert false
- | ("Lustre", "condact") -> assert false
+ | ("Lustre", "fillred") -> do_fillred nk2nd nk lxm
+ | ("Lustre", "boolred") -> do_boolred nk2nd nk lxm
+ | ("Lustre", "condact") -> do_condact nk2nd nk lxm
| _ -> raise Not_found
(*--------------------------------------------------------------------
@@ -69,3 +79,121 @@ and do_map nk2nd nk lxm =
has_mem_eff = nd.has_mem_eff;
is_safe_eff = nd.is_safe_eff;
}
+(*--------------------------------------------------------------------
+FILLRED
+----------------------------------------------------------------------
+ Given :
+ - A node : aa * a_1 * ... * a_n -> aa * b_1 * ... * b_k
+ - An int c
+Gen a node : aa * a_1^c * ... * a_n^c -> aa * b_1^c * ... * b_k^c
+--------------------------------------------------------------------*)
+and do_fillred nk2nd nk lxm =
+ let sargs = snd nk in
+ let (np, c) = get_node_and_int_const lxm sargs in
+ let nd = nk2nd np in
+ let ins = nd.inlist_eff in
+ let outs = nd.outlist_eff in
+ let _ = assert (ins <> [] && outs <> []) in
+ let ins' = (List.hd ins)::(List.map (var_to_array c) (List.tl ins)) in
+ let outs' = (List.hd outs)::(List.map (var_to_array c) (List.tl outs)) in
+ (* pas d'unif : egalité et c'est tout ! *)
+ let t1 = (List.hd ins').var_type_eff in
+ let t2 = (List.hd outs').var_type_eff in
+ if t1 <> t2 then
+ let msg = Printf.sprintf
+ "node can't be used in iterator, first input type '%s' differs from first output type '%s'"
+ (LicDump.string_of_type_eff t1)
+ (LicDump.string_of_type_eff t2)
+ in
+ raise (Compile_error(lxm, msg))
+ else
+ {
+ node_key_eff = nk;
+ inlist_eff = ins';
+ outlist_eff = outs';
+ loclist_eff = None;
+ def_eff = BuiltInEff;
+ has_mem_eff = nd.has_mem_eff;
+ is_safe_eff = nd.is_safe_eff;
+ }
+(*--------------------------------------------------------------------
+CONDACT
+----------------------------------------------------------------------
+ Given :
+ - A node n of type: a_1 * ... * a_n -> b_1 * ... * b_k
+ - A (tuple) const: b_1 * ... * b_k
+Gen a node of type : bool * a_1 * ... * a_n -> b_1 * ... * b_k
+---------------------------------------------------------------------*)
+and do_condact nk2nd nk lxm =
+try
+ let sargs = snd nk in
+ let nk, dflt =
+ match sargs with
+ | [NodeStaticArgEff(_,nk) ; ConstStaticArgEff(_,dflt)] -> nk, dflt
+ | _ -> assert false
+ in
+ (* recherche le profil de nk ... *)
+ let ne = nk2nd nk in
+ let inlist = ne.inlist_eff in
+ let outlist = ne.outlist_eff in
+ (* dflt_types doit êre compatiple avec outlist *)
+ let dflt_types = types_of_const dflt in
+ let out_types = List.map (fun x -> x.var_type_eff) outlist in
+ let matches = try
+ UnifyType.is_matched out_types dflt_types
+ with UnifyType.Match_failed msg ->
+ raise (Compile_error(lxm, "in condact default output "^msg))
+ in
+ let out_types = Eff.apply_type_matches matches out_types in
+ let in_types = Eff.apply_type_matches matches
+ (Bool_type_eff::(List.map (fun x -> x.var_type_eff) inlist))
+ in
+ (* ok pour les args statiques, le profil dynamique est : *)
+ let ins = Eff.create_var_list SyntaxTreeCore.VarInput in_types in
+ let outs = Eff.create_var_list SyntaxTreeCore.VarOutput out_types in
+ {
+ node_key_eff = nk;
+ inlist_eff = ins;
+ outlist_eff = outs;
+ loclist_eff = None;
+ def_eff = BuiltInEff;
+ has_mem_eff = ne.has_mem_eff;
+ is_safe_eff = ne.is_safe_eff;
+ }
+with
+| EvalType_error msg -> raise (Compile_error(lxm, "type error: "^msg))
+
+
+
+
+(*--------------------------------------------------------------------
+BOOLRED
+----------------------------------------------------------------------
+ Given
+ - 3 integer constant i, j, k
+
+ returns the profile bool^k -> bool
+---------------------------------------------------------------------*)
+and do_boolred nk2nd nk lxm =
+ let sargs = snd nk in
+ let (i,j,k) = match sargs with
+ | [
+ ConstStaticArgEff(_,Int_const_eff i);
+ ConstStaticArgEff(_,Int_const_eff j);
+ ConstStaticArgEff(_,Int_const_eff k)
+ ] -> i,j,k
+ | _ -> raise (Compile_error(lxm, "\n*** type error: 3 int were expected"))
+ in
+ let ins = Eff.create_var_list SyntaxTreeCore.VarInput [ Array_type_eff(Bool_type_eff,k) ] in
+ let outs = Eff.create_var_list SyntaxTreeCore.VarOutput [ Bool_type_eff ] in
+ {
+ node_key_eff = nk;
+ inlist_eff = ins;
+ outlist_eff = outs;
+ loclist_eff = None;
+ def_eff = BuiltInEff;
+ (* ???? *)
+ has_mem_eff = true;
+ is_safe_eff = true;
+ }
+
diff --git a/src/doNoPoly.ml b/src/doNoPoly.ml
index 0fd99e6c338e83e02d2f8b1dee3229622916b376..452b230e45864c7cb5abb449a43945e16f13d1cb 100644
--- a/src/doNoPoly.ml
+++ b/src/doNoPoly.ml
@@ -54,6 +54,7 @@ let rec doit (inp : LicPrg.t) : LicPrg.t =
else ();
let def' = match ne.def_eff with
| ExternEff -> ne.def_eff
+ | BuiltInEff _ -> BuiltInEff
| AbstractEff _ -> assert false
| BodyEff nb ->
BodyEff (do_body nb)
diff --git a/src/eff.ml b/src/eff.ml
index f0545ebcfcc802947bd864a1a1f1f71709a3c51a..7feb348174e7ce4f82d9ad502bed9abe67675c8a 100644
--- a/src/eff.ml
+++ b/src/eff.ml
@@ -541,6 +541,11 @@ let rec subst_matches (matches: type_matches) (t: type_) : type_ =
| TypeVar tvar ->
try (List.assoc tvar matches) with Not_found -> t
+let apply_type_matches (matches: type_matches) (tl: type_ list) : type_ list =
+ match matches with
+ | [] -> tl
+ | _ -> List.map (subst_matches matches) tl
+
let rec (type_is_poly : type_ -> bool) =
fun t -> match t with
@@ -710,6 +715,28 @@ and string_of_type_matches pm =
(* NodeStaticArgEff of (Ident.t * sarg_node_eff * node_exp) *)
(* sarg_node_eff = node_key * var_info list * var_info list *)
+(* utile : liste standard de var_info a partir de liste de type *)
+let create_var_list nat tl = (
+ let pfx = match nat with
+ | SyntaxTreeCore.VarInput -> "i"
+ | SyntaxTreeCore.VarOutput -> "o"
+ | SyntaxTreeCore.VarLocal -> assert false
+ in
+ let cpt = ref 0 in
+ let dovar t = (
+ let i = !cpt in
+ let id = Printf.sprintf "%s%d" pfx i in
+ incr cpt;
+ {
+ var_name_eff = id;
+ var_nature_eff = nat;
+ var_number_eff = i;
+ var_type_eff = t;
+ (* ???? *)
+ var_clock_eff = (id, BaseEff);
+ }
+ ) in List.map dovar tl
+)
(*---------------------------------------------------------------------
Une erreur associée à un noeud + 1 lexeme dans le fichier source
diff --git a/src/evalType.ml b/src/evalType.ml
index 86442ba09adc89ba0bd8feaf2dd793df9f311192..de5f6d29dc4bfa0340c1fe6da4bd41ae8cc6b250 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -111,7 +111,7 @@ and eval_by_pos_type
Printf.fprintf stderr "# required matches %s\n"
(Eff.string_of_type_matches tmatches)
);
- List.map (Eff.subst_matches tmatches) lto
+ Eff.apply_type_matches tmatches lto
in
(*
let subst_opt = match U nifyType.f lti t_args with
diff --git a/src/licDump.ml b/src/licDump.ml
index eeadfc8cb92d75e6f146604a7d91dfe8ddf2a289..dcfebcb896254f0f8c2b10f651b7eb5e80e4ab93 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -542,7 +542,7 @@ and wrap_long_profile str =
and (profile_of_node_exp_eff: Eff.node_exp -> string) =
fun neff ->
("(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
- (string_of_type_decl_list neff.outlist_eff "; ") ^ ");\n")
+ (string_of_type_decl_list neff.outlist_eff "; ") ^ ")")
and (string_of_node_def : Eff.node_def -> string list) =
function
@@ -598,36 +598,51 @@ and (const_decl: Ident.long -> Eff.const -> string) =
(* exported *)
-and (node_of_node_exp_eff: Eff.node_exp -> string) =
- fun neff ->
- wrap_long_profile (
- (if
- neff.def_eff = ExternEff
- && not (!Global.lv4) (* no extern kwd in v4... *)
- then "extern "
- else "") ^
- (if !Global.lv4 then
- (* node and function does not have the same meaning in v4... *)
- (if neff.def_eff = ExternEff then "function " else "node ")
- else
- (if neff.has_mem_eff then "node " else "function ")
- ) ^
- (string_of_node_key_rec neff.node_key_eff) ^
- (profile_of_node_exp_eff neff)) ^
- (match neff.def_eff with
- | ExternEff -> ""
- | BuiltInEff -> ""
+and node_of_node_exp_eff
+ (neff: Eff.node_exp)
+: string =
+ wrap_long_profile (
+
+ (
+ if neff.def_eff = ExternEff && not (!Global.lv4)
+ (* no extern kwd in v4... *)
+ then "extern " else ""
+ )^(
+ if !Global.lv4 then (
+ (* node and function does not have the same meaning in v4... *)
+ if neff.def_eff = ExternEff then "function " else "node "
+ ) else (
+ if neff.has_mem_eff then "node " else "function "
+ )
+ )^(
+ string_of_node_key_rec neff.node_key_eff
+ )^(
+ profile_of_node_exp_eff neff
+ )
+ )^(
+ match neff.def_eff with
+ | ExternEff -> ";\n"
+ | BuiltInEff -> (
(* on écrit juste un alias *)
- | AbstractEff _ -> ""
- | BodyEff _ ->
- ((match neff.loclist_eff with None -> "" | Some [] -> ""
- | Some l ->
- "var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n") ^
- "let\n " ^
- (String.concat "\n " (string_of_node_def neff.def_eff)) ^
- "\ntel\n-- end of node " ^
- (string_of_node_key_rec neff.node_key_eff) ^ "\n"
- )
+ " = "^
+ (string_of_node_key_iter neff.node_key_eff)^
+ (";\n")
+ )
+ | AbstractEff _ -> ";\n"
+ | BodyEff _ -> (
+ ";\n"^
+ (
+ match neff.loclist_eff with
+ | None -> ""
+ | Some [] -> ""
+ | Some l ->
+ "var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n"
+ ) ^
+ "let\n " ^
+ (String.concat "\n " (string_of_node_def neff.def_eff)) ^
+ "\ntel\n-- end of node " ^
+ (string_of_node_key_rec neff.node_key_eff) ^ "\n"
+ )
)
diff --git a/test_static/cond01.lus b/test_static/cond01.lus
new file mode 100644
index 0000000000000000000000000000000000000000..7fa845872d76e754a51189f4980dc954bde1ba81
--- /dev/null
+++ b/test_static/cond01.lus
@@ -0,0 +1,5 @@
+
+node main(c: bool; x,y:int) returns (o: int);
+let
+ o = condact<<+,0>>(x,y);
+tel
diff --git a/test_static/predef02.lus b/test_static/predef02.lus
new file mode 100644
index 0000000000000000000000000000000000000000..5f5822e9f90e0fc9e9d3e2eebea7f024194569b2
--- /dev/null
+++ b/test_static/predef02.lus
@@ -0,0 +1,7 @@
+
+
+
+node main(x: bool^42) returns (o: bool);
+let
+ o = red<<or, 42>>(false,x);
+tel
diff --git a/test_static/predef03.lus b/test_static/predef03.lus
new file mode 100644
index 0000000000000000000000000000000000000000..c9e9dcac95e3973048686871023c9a070cea8b5d
--- /dev/null
+++ b/test_static/predef03.lus
@@ -0,0 +1,7 @@
+
+
+
+node main(x: bool^13) returns (o: bool);
+let
+ o = boolred<<1,2,13>>(x);
+tel