diff --git a/src/eff.ml b/src/eff.ml
index 1f5ae5708e9049014bf039374882399df7e37228..8ce7dd8a6713afa90b35304ece30620d75f0f65d 100644
--- a/src/eff.ml
+++ b/src/eff.ml
@@ -132,6 +132,8 @@ and type_ =
| Overload
(* [Overload] is like [Any], except that it can only be [int] or [real] *)
+(* Utile : arguments et profils *)
+and node_profile = (Ident.t * type_) list * (Ident.t * type_) list
and slice_info = {
(** Dénotation de tranche de tableau correcte :
@@ -240,6 +242,7 @@ and const =
| Struct_const_eff of ((Ident.t * const) list * type_)
(* type_ tableau : liste des valeurs + type_ des elts + taille *)
| Array_const_eff of (const list * type_)
+ | Tuple_const_eff of const list
(*---------------------------------------------------------------------
Type: val
-----------------------------------------------------------------------
@@ -315,6 +318,7 @@ and node_body = {
and item_key = Ident.long
and node_key = item_key * static_arg list
and static_arg =
+ (* may be a tuple *)
| ConstStaticArgEff of (Ident.t * const)
| TypeStaticArgEff of (Ident.t * type_)
| NodeStaticArgEff of (Ident.t * sarg_node_eff * node_exp)
diff --git a/src/getEff.ml b/src/getEff.ml
index 33f86e551b51660f7733cba27ef89ec2a9dd10fe..81f2f546849c7a8a31ab6fcebe95d3c8cb888b48 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -377,64 +377,13 @@ and (translate_val_exp : Eff.id_solver -> UnifyClock.subst ->
in
let s, vef_core =
match by_pos_op with
- (* put that in another module ? yes, see above.*)
-(*
- | Predef_n(CondAct, sargs)
- | Predef_n(Map, sargs)
- | Predef_n(Fill, sargs)
- | Predef_n(Red, sargs)
- | Predef_n(FillRed, sargs)
- | Predef_n(BoolRed, sargs) ->
- (* We will make use of [vel_eff] to resolve the polymorphism *)
- let vel_eff, type_ll =
- List.split (List.map (EvalType.f id_solver) vel_eff)
- in
- let type_l : Eff.type_ list = List.flatten type_ll in
- let sargs_eff = translate_predef_static_args id_solver sargs lxm in
- let iter_op = match by_pos_op with
- Predef_n(op,_) -> op | _ -> assert false
- in
- let iter_profile = match by_pos_op with
- | Predef_n(Map,_) ->
- PredefEvalType.map_profile lxm sargs_eff
- | Predef_n(Fill,_) | Predef_n(Red,_) | Predef_n(FillRed,_) ->
- PredefEvalType.fillred_profile lxm sargs_eff
- | Predef_n(BoolRed,_) ->
- PredefEvalType.boolred_profile lxm sargs_eff
- | _ -> assert false
- in
- let type_l_exp = snd (List.split (fst iter_profile)) in
- let sargs_eff =
- if List.length type_l <> List.length type_l_exp then
- let str = Printf.sprintf
- "the iterator has a wrong arity: %s instead of %s"
- (string_of_int (List.length type_l))
- (string_of_int (List.length type_l_exp))
- in
- raise (Compile_error(lxm, str))
- else
- match UnifyType.f type_l type_l_exp with
- | UnifyType.Equal -> sargs_eff
- | UnifyType.Unif typ ->
- (* The iterated nodes was polymorphic, but we know here
- that the type variable was [typ].
- *)
- dump_polymorphic_nodes typ;
- List.map (instanciate_type typ) sargs_eff
-
- | UnifyType.Ko str -> raise (Compile_error(lxm, str))
- in
- s, mk_by_pos_op (Eff.Predef(iter_op, sargs_eff))
-
- (* other predef operators *)
- | Predef_n(op, args) ->
-*)
+ (* put that in another module ? yes, see above.*)
| Predef_n(op, sargs) -> (
- try translate_predef_macro id_solver lxm op sargs (s, vel_eff)
- with Not_found ->
- assert (sargs=[]);
- s, mk_by_pos_op(Predef (op,[]))
- )
+ try translate_predef_macro id_solver lxm op sargs (s, vel_eff)
+ with Not_found ->
+ assert (sargs=[]);
+ s, mk_by_pos_op(Predef (op,[]))
+ )
| CALL_n node_exp_f ->
s, mk_by_pos_op(Eff.CALL (flagit (node id_solver node_exp_f)
node_exp_f.src))
@@ -533,14 +482,20 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
in
let type_l : Eff.type_ list = List.flatten type_ll in
+ (* Vérif légère du profil statique : vérifie si le nombre et la nature
+ d'arg peut convenir *)
let sargs_eff = translate_predef_static_args id_solver zemacro sargs lxm in
+ (* Vérif complète du type, on utilise des fonctions ad hoc pour
+ chaque macro predef, (AFAIRE : pas très beau ... *)
let iter_profile = match zemacro with
- | Map ->
+ | Map ->
PredefEvalType.map_profile lxm sargs_eff
| Fill | Red | FillRed ->
PredefEvalType.fillred_profile lxm sargs_eff
- | BoolRed ->
+ | BoolRed ->
PredefEvalType.boolred_profile lxm sargs_eff
+ | CondAct ->
+ PredefEvalType.condact_profile lxm sargs_eff
| _ -> raise Not_found
in
let type_l_exp = snd (List.split (fst iter_profile)) in
@@ -725,12 +680,26 @@ and translate_predef_static_args
]
| _ -> raise (Compile_error(lxm, "bad arguments number for array iterator"))
)
+ | CondAct -> (
+ (* expects 1 node, 1 (tuple) constant *)
+ match sargs with
+ | [n; d] ->
+ let node_eff = get_node id_solver n.it n.src in
+ let node_arg =
+ node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff
+ in
+ [
+ NodeStaticArgEff(Ident.of_string "node", node_arg, node_eff);
+ ConstStaticArgEff(Ident.of_string "default", get_const id_solver d.it d.src)
+ ]
+ | _ -> raise (Compile_error(lxm, "bad arguments number for condact macro"))
+ )
| _ -> (
(* expects 0 sargs ! *)
match sargs with
| [] -> []
| _ ->
- raise (Compile_error(lxm, "bad arguments number for array iterator"))
+ raise (Compile_error(lxm, "bad arguments number for predef macro"))
)
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index d5eace705ed82321e8b8677218f4cce456f468bf..71233ae2346287256801be85fed06eb90b79c8eb 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -724,7 +724,8 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
(fun id lxm ->
try lookup_const local_env id lxm
with Not_found ->
- solve_const_idref this symbols provide_flag pack_name id lxm);
+ solve_const_idref this symbols provide_flag pack_name id lxm
+ );
id2type =
(fun id lxm ->
try lookup_type local_env id lxm
diff --git a/src/licDump.ml b/src/licDump.ml
index ef7dd5300a7df90ee6f1917a21d6fab34620d1b0..15d3e1974388eef998370f0e331fe63b2469a9d1 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -74,6 +74,10 @@ let rec string_of_const_eff =
let vl = List.map string_of_const_eff ctab in
"["^(String.concat ", " vl)^"]"
)
+and string_of_const_eff_list =
+ function
+ | [c] -> string_of_const_eff c
+ | cl -> "(" ^ (String.concat ", " (List.map string_of_const_eff cl)) ^ ")"
(* modify numbers notations in such a way that they
become "valid" identifiers. Policy:
@@ -113,6 +117,11 @@ and string_ident_of_const_eff c =
)
| Array_const_eff (ctab, t) -> string_of_type_eff t
+and string_ident_of_const_eff_list cl =
+ match cl with
+ | [c] -> string_ident_of_const_eff c
+ | _ -> "(" ^ (String.concat ", " (List.map string_ident_of_const_eff cl)) ^ ")"
+
and string_of_const_eff_opt = function
| None -> ""
| Some val_exp_eff -> string_of_const_eff val_exp_eff
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index 82a8feef9c91521b8054dfca6f77191bdc1dd9b8..418b4fc642bb305da8f7258d8773f31950519630 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -75,56 +75,63 @@ let (type_to_array_type: Eff.var_info list -> int -> (Ident.t * Eff.type_) list)
List.map (fun vi -> vi.var_name_eff, Array_type_eff(vi.var_type_eff,c)) l
(* Extract the node and the constant from a list of static args *)
-let (get_node_and_constant: Lxm.t ->
+let (get_node_and_int_const: Lxm.t ->
Eff.static_arg list -> Eff.item_key * var_info list * var_info list * int) =
fun lxm sargs ->
match sargs with
| [NodeStaticArgEff(_,((n,_), inlist, outlist), _);
- ConstStaticArgEff(_,Int_const_eff c)] -> n, inlist, outlist, c
+ ConstStaticArgEff(_, Int_const_eff c)] -> n, inlist, outlist, c
- | [NodeStaticArgEff(_,((n,_), inlist, outlist), _);
+ | [
+ NodeStaticArgEff(_,((n,_), inlist, outlist), _);
ConstStaticArgEff(_, Abstract_const_eff(l,_,Int_const_eff c, true))] ->
n, inlist, outlist, c
- | [NodeStaticArgEff(_,_,_); ConstStaticArgEff(_, Extern_const_eff(l, _))] ->
- let msg = "an integer is expected, whereas an extern constant (" ^
- (Ident.string_of_long l) ^ ") was provided.\n"
- in
- raise (Compile_error(lxm, msg))
- | [NodeStaticArgEff(_,_,_); ConstStaticArgEff(_, Abstract_const_eff(l,_,_, false))] ->
- let msg = "an integer is expected, whereas an abstract constant (" ^
- (Ident.string_of_long l) ^ ") was provided.\n"
- in
- raise (Compile_error(lxm, msg))
- | [NodeStaticArgEff(_,((n,_), inlist, outlist),_); ConstStaticArgEff(_, const)] ->
- let msg = "an integer is expected, whereas a " ^
- (LicDump.string_of_type_eff4msg (Eff.type_of_const const)) ^
- " was provided.\n"
- in
- raise (Compile_error(lxm, msg))
- | _ ->
- let msg = "*** an integer and a node are expected.\n" in
- raise (Compile_error(lxm, msg))
+ | [NodeStaticArgEff(_,_,_);
+ ConstStaticArgEff(_, zcl) ]
+ ->
+ let msg = "immediate integer expected, but get \""
+ ^ (LicDump.string_of_const_eff zcl)
+ ^ "\"\n"
+ in raise (Compile_error(lxm, msg))
+ | _ ->
+ let msg = "*** an integer and a node are expected.\n" in
+ raise (Compile_error(lxm, msg))
+
+(*---------------------------------------------------------------------
+Typers for predef macros/iterators
+---------------------------------------------------------------------*)
+let get_id_type vi = vi.var_name_eff, vi.var_type_eff
-let map_profile =
- (* Given
- - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
- - a constant c (nb : sargs = [n,c])
-
- The profile of map is: tau_1^c * ... * tau_n^c -> teta_1^c * ... * teta_l^c
- *)
- fun lxm sargs ->
- let (n, inlist, outlist, c) = get_node_and_constant lxm sargs in
+
+let condact_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
+(* Given
+ - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+ - a (tuple) constant dflt : teta_1 * ... * teta_l
+ The profile of condact is:
+ bool * tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+*)
+ let n, inlist, outlist, dflt =
+ match sargs with
+ [NodeStaticArgEff(_,((n,_), inlist, outlist), _);
+ ConstStaticArgEff(_,dflt)] -> n, inlist, outlist, dflt in
+ assert false
+
+
+let map_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
+(* Given
+ - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+ - a constant c (nb : sargs = [n,c])
+ The profile of map is: tau_1^c * ... * tau_n^c -> teta_1^c * ... * teta_l^c
+*)
+ let (n, inlist, outlist, c) = get_node_and_int_const lxm sargs in
let lti = type_to_array_type inlist c in
let lto = type_to_array_type outlist c in
let res = (lti, lto) in
res
-let get_id_type vi = vi.var_name_eff, vi.var_type_eff
-
-let (fillred_profile : Lxm.t -> Eff.static_arg list ->
- (Ident.t * Eff.type_) list * (Ident.t * Eff.type_) list) =
+let fillred_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
(* Given
- a node n of type tau * tau_1 * ... * tau_n -> tau * teta_1 * ... * teta_l
- a constant c (nb : sargs = [n,c])
@@ -132,8 +139,7 @@ let (fillred_profile : Lxm.t -> Eff.static_arg list ->
returns the profile:
tau * tau_1^c * ... * tau_n^c -> tau * teta_1^c * ... * teta_l^c
*)
- fun lxm sargs ->
- let (n, inlist, outlist, c) = get_node_and_constant lxm sargs in
+ let (n, inlist, outlist, c) = get_node_and_int_const lxm sargs in
let _ = assert(inlist <> [] && outlist <> []) in
let lti = (get_id_type (List.hd inlist))::
type_to_array_type (List.tl inlist) c in
@@ -172,8 +178,7 @@ let (fillred_profile : Lxm.t -> Eff.static_arg list ->
returns the profile bool^k -> bool
*)
-let boolred_profile =
- fun lxm sargs ->
+let boolred_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
let (get_three_constants: Lxm.t -> Eff.static_arg list -> int * int * int) =
fun lxm sargs ->
match sargs with
@@ -184,13 +189,11 @@ let boolred_profile =
in
let (_i,_j,k) = get_three_constants lxm sargs in
[id "i", (Array_type_eff(Bool_type_eff,k))], [id "o", b]
-
-
-type node_profile = (Ident.t * Eff.type_) list * (Ident.t * Eff.type_) list
+(*---------------------------------------------------------------------*)
-let (op2profile : Predef.op -> Lxm.t -> Eff.static_arg list -> node_profile) =
+let (op2profile : Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_profile) =
fun op lxm sargs ->
let res =
match op with
diff --git a/src/predefEvalType.mli b/src/predefEvalType.mli
index 76839f7eb6879b7d09ab2f7983b1a94e72e0a71b..b4034a45486795d9b208e51798ac8ee9cd812107 100644
--- a/src/predefEvalType.mli
+++ b/src/predefEvalType.mli
@@ -18,9 +18,8 @@ val f : Predef.op -> Lxm.t -> Eff.static_arg list -> typer
val make_node_exp_eff :
bool option -> Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_exp
-
-type node_profile = (Ident.t * Eff.type_) list * (Ident.t * Eff.type_) list
-
-val fillred_profile : Lxm.t -> Eff.static_arg list -> node_profile
-val map_profile : Lxm.t -> Eff.static_arg list -> node_profile
-val boolred_profile : Lxm.t -> Eff.static_arg list -> node_profile
+(* TODO : rather ugly, one type-checker per macro ! *)
+val fillred_profile : Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val map_profile : Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val boolred_profile : Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val condact_profile : Lxm.t -> Eff.static_arg list -> Eff.node_profile