diff --git a/over2.lus b/over2.lus
index 3bba0ff60580bd09e138610d5ddae0c70ca1a6c3..44f26b81275e71c3f96ce0894fd4cf58da2b5510 100644
--- a/over2.lus
+++ b/over2.lus
@@ -18,3 +18,5 @@ let o = overplus(x,y); tel
node tata(x,y: int^13^22) returns (o: int^13^22);
let o = map<<map<<+,13>>, 22>>(x,y); tel
+node bibi(x,y: int^55) returns (o: int^55);
+let o = map<<+,55>>(x,y); tel
diff --git a/src/doNoPoly.ml b/src/doNoPoly.ml
index 6bcb2f8573714cba0631bedfceaf76771e9b89b1..0fd99e6c338e83e02d2f8b1dee3229622916b376 100644
--- a/src/doNoPoly.ml
+++ b/src/doNoPoly.ml
@@ -89,8 +89,9 @@ let rec doit (inp : LicPrg.t) : LicPrg.t =
(* pop : Predef.op *)
(* un des arguments stat est un noeud poly ? *)
let check_sa = function
- | NodeStaticArgEff (id, (nk, ins,outs), nexp) ->
- if node_is_poly nexp then (
+ | NodeStaticArgEff (id, nk) ->
+ let ne = LicPrg.find_node inp nk in
+ if node_is_poly ne then (
Printf.fprintf stderr "#DBG: CALL predef node %s uses poly node %s\n"
(Lxm.details posop.src)
(Eff.string_of_node_key nk)
diff --git a/src/eff.ml b/src/eff.ml
index 7087ec98bc33cc30d91bf46ac2c97f8fdd345c27..f5a7bfa21d78a288bd60f278a5d2a11ae9967019 100644
--- a/src/eff.ml
+++ b/src/eff.ml
@@ -338,7 +338,8 @@ 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)
+ (* | NodeStaticArgEff of (Ident.t * sarg_node_eff * node_exp) *)
+ | NodeStaticArgEff of (Ident.t * node_key)
and sarg_node_eff = node_key * var_info list * var_info list
@@ -403,7 +404,8 @@ type local_env = {
(* lenv_globals : pack_env ; *)
lenv_types : (Ident.t, type_) Hashtbl.t ;
lenv_const : (Ident.t, const) Hashtbl.t ;
- lenv_nodes : (Ident.t, sarg_node_eff) Hashtbl.t ;
+ (* lenv_nodes : (Ident.t, sarg_node_eff) Hashtbl.t ; *)
+ lenv_nodes : (Ident.t, node_key) Hashtbl.t ;
lenv_vars : (Ident.t, var_info) Hashtbl.t ;
}
@@ -419,9 +421,14 @@ let (lookup_type: local_env -> Ident.idref -> Lxm.t -> type_) =
fun env id lxm ->
Hashtbl.find env.lenv_types (Ident.name_of_idref id)
-let (lookup_node:
- local_env -> Ident.idref -> static_arg list -> Lxm.t -> sarg_node_eff) =
- fun env id sargs lmx ->
+let lookup_node
+ (env: local_env)
+ (id: Ident.idref)
+ (sargs: static_arg list)
+ (lxm: Lxm.t)
+(* : sarg_node_eff = *)
+: node_key =
+
Hashtbl.find env.lenv_nodes (Ident.name_of_idref id)
let (lookup_const: local_env -> Ident.idref -> Lxm.t -> const) =
@@ -685,8 +692,9 @@ and string_of_node_key = function
and string_of_static_arg = function
| ConstStaticArgEff (id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
| TypeStaticArgEff (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type teff)
-| NodeStaticArgEff (id, ((long,sargs), _, _), _) ->
- Printf.sprintf "node %s = %s" id (string_of_node_key (long,sargs))
+(* | NodeStaticArgEff (id, ((long,sargs), _, _), _) -> *)
+| NodeStaticArgEff (id, nk) ->
+ Printf.sprintf "node %s = %s" id (string_of_node_key nk)
and string_of_type_matches pm =
let sotm (tv,t) = Printf.sprintf "%s <- %s"
@@ -721,7 +729,8 @@ let (make_local_env : node_key -> local_env) =
(function
| ConstStaticArgEff(id,ce) -> Hashtbl.add res.lenv_const id ce
| TypeStaticArgEff(id,te) -> Hashtbl.add res.lenv_types id te
- | NodeStaticArgEff(id, ne, _) -> Hashtbl.add res.lenv_nodes id ne
+ (* | NodeStaticArgEff(id, ne, _) -> Hashtbl.add res.lenv_nodes id ne *)
+ | NodeStaticArgEff(id, nk) -> Hashtbl.add res.lenv_nodes id nk
)
(snd nk);
@@ -732,5 +741,6 @@ let dump_local_env oc e =
Hashtbl.iter pt e.lenv_types;
let pc i t = Printf.fprintf oc "# const %s = %s\n" i (string_of_const t) in
Hashtbl.iter pc e.lenv_const;
- let pn i (n,_,_) = Printf.fprintf oc "# node %s = %s\n" i (string_of_node_key n) in
+ (* let pn i (n,_,_) = Printf.fprintf oc "# node %s = %s\n" i (string_of_node_key n) in *)
+ let pn i nk = Printf.fprintf oc "# node %s = %s\n" i (string_of_node_key nk) in
Hashtbl.iter pn e.lenv_nodes;
diff --git a/src/evalClock.ml b/src/evalClock.ml
index 2cf4178b7707c8e97a5ce440f518f5c98a34622d..75f72658c4c13378a660943766dbd3e122138c90 100644
--- a/src/evalClock.ml
+++ b/src/evalClock.ml
@@ -380,7 +380,7 @@ and (eval_by_pos_clock : Eff.id_solver -> Eff.by_pos_op -> Lxm.t -> Eff.val_exp
let _clk,s = UnifyClock.list lxm flat_clk_args s in
List.map (List.map (apply_subst s)) clk_args, s
in
- PredefEvalClock.f op lxm sargs s clk_list
+ PredefEvalClock.f id_solver op lxm sargs s clk_list
(* may have tuples as arguments *)
| Eff.TUPLE,args
diff --git a/src/evalConst.ml b/src/evalConst.ml
index 764f4221ceeb83e2f6b16b80b32a72d0375104f5..1c1e0780d5ce7c0b8c4562cb2cac9c02d7faf9de 100644
--- a/src/evalConst.ml
+++ b/src/evalConst.ml
@@ -332,10 +332,10 @@ let rec f
->
if sargs = [] then
let effargs = (List.map rec_eval_const args) in
- PredefEvalConst.f op lxm [] effargs
+ PredefEvalConst.f env op.it lxm [] effargs
else
(* Well, it migth be possible after all... TODO *)
- not_evaluable_construct (op2string op)
+ not_evaluable_construct (op2string op.it)
) (* FIN DE : eval_by_pos_const *)
diff --git a/src/evalType.ml b/src/evalType.ml
index 315fad592f4f8feb0d17a3bcfd38b1875f5e10cc..86442ba09adc89ba0bd8feaf2dd793df9f311192 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -75,7 +75,7 @@ and eval_by_pos_type
| PREDEF_CALL (op,sargs) -> (
let args, targs = List.split (List.map (f id_solver) args) in
(* ICI pas de matches possible ? *)
- let tve = PredefEvalType.f op lxm sargs targs in
+ let tve = PredefEvalType.f id_solver op lxm sargs targs in
None, args, tve
)
| Eff.CALL nkf ->
diff --git a/src/getEff.ml b/src/getEff.ml
index ae073c6230354fcfcb64714370d7ea62e184d671..18bba04a7220436488d0f31bca21724ef9bccb87 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -142,6 +142,10 @@ let rec (of_node : Eff.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
etre un static param node
*)
+(*
+C'EST ICI QU'IL FAUT TRAITER LES MACROS PREDEF !
+*)
+
let static_args_eff = match static_args with
| [] -> []
| _ ->
@@ -253,21 +257,27 @@ and (check_static_arg : Eff.id_solver ->
(* idref is an alias, hence it cannot have static argument *)
let sargs = [] in
let neff = node_id_solver.id2node idref sargs sa.src in
- let (inlist, outlist) = check_node_arg neff vii vio in
- NodeStaticArgEff (id, (neff.node_key_eff, inlist, outlist), neff)
+ (* ICI a revoir ? *)
+ (* let (inlist, outlist) = check_node_arg neff vii vio in *)
+ let _ = check_node_arg neff vii vio in
+ NodeStaticArgEff (id, neff.node_key_eff)
| StaticArgNode(CALL_n ne), StaticParamNode(id,vii,vio,_) ->
let neff = of_node node_id_solver ne in
- let (inlist, outlist) = check_node_arg neff vii vio in
- NodeStaticArgEff (id, (neff.node_key_eff, inlist, outlist), neff)
+ (* ICI a revoir ? *)
+ (* let (inlist, outlist) = check_node_arg neff vii vio in *)
+ let _ = check_node_arg neff vii vio in
+ NodeStaticArgEff (id, neff.node_key_eff)
| StaticArgNode(Predef_n (op,sargs)), StaticParamNode(id,vii,vio,_) ->
let sargs_eff =
- translate_predef_static_args node_id_solver op sargs sa.src
+ translate_predef_static_args node_id_solver op.it sargs sa.src
in
- let opeff = PredefEvalType.make_node_exp_eff None op sa.src sargs_eff in
- let (inlist, outlist) = check_node_arg opeff vii vio in
- NodeStaticArgEff (id, (opeff.node_key_eff, inlist, outlist), opeff)
+ let opeff = PredefEvalType.make_node_exp_eff node_id_solver None op.it sa.src sargs_eff in
+ (* ICI a revoir ? *)
+ (* let (inlist, outlist) = check_node_arg opeff vii vio in *)
+ let _ = check_node_arg opeff vii vio in
+ NodeStaticArgEff (id, opeff.node_key_eff)
| StaticArgNode(
(MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _|IDENT_n _
@@ -385,13 +395,38 @@ 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.*)
+ (* put that in another module ? yes, see above.*)
| Predef_n(op, sargs) -> (
+ (* 12/07 SOLUTION INTERMEDIAIRE
+ - les macros predefs ne sont plus traitées ici
+ on les transforme en CALL standard
+ N.B. on garde pour l'instant la notion de
+ PREDEF_CALL pour les op simple, mais à terme
+ ça devrait disparaitre aussi ...
+ *)
+ (* OBSOLETE
try translate_predef_macro id_solver lxm op sargs (s, vel_eff)
with Not_found ->
assert (sargs=[]);
s, mk_by_pos_op(PREDEF_CALL (op,[]))
- )
+ *)
+ match sargs with
+ | [] -> s, mk_by_pos_op(PREDEF_CALL (op.it,[]))
+ | _ ->
+ (* on re-construit une SyntaxTreeCore.node_exp srcflagged
+ parce que c'est ca qu'attend of_node ...
+ *)
+ let node_exp_f = flagit (Predef.op_to_idref op.it, sargs) op.src in
+ let neff = of_node id_solver node_exp_f in
+ let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
+ Verbose.exe ~flag:dbg (fun () ->
+ Printf.fprintf stderr "#DBG: GetEff.translate_val_exp Predef_n '%!";
+ SyntaxTreeDump.print_node_exp stderr node_exp_f.it;
+ Printf.fprintf stderr " gives type: %s\n%!"
+ (Eff.string_of_type_profile (profile_of_node_exp neff))
+ ) ;
+ (s, mk_by_pos_op ceff)
+ )
| CALL_n node_exp_f ->
let neff = of_node id_solver node_exp_f in
let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
@@ -511,21 +546,21 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
(* 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
+ let sargs_eff = translate_predef_static_args id_solver zemacro.it sargs lxm in
(* Vérif complète du type, on utilise des fonctions ad hoc pour
chaque macro predef, (AFAIRE : pas très beau ...)
N.B. le resultat est un Eff.node_profile = ins -> outs
où les in/out sont des ident * type_
*)
- let iter_profile = match zemacro with
+ let iter_profile = match zemacro.it with
| Map ->
- PredefEvalType.map_profile lxm sargs_eff
+ PredefEvalType.map_profile id_solver lxm sargs_eff
| Fill | Red | FillRed ->
- PredefEvalType.fillred_profile lxm sargs_eff
+ PredefEvalType.fillred_profile id_solver lxm sargs_eff
| BoolRed ->
- PredefEvalType.boolred_profile lxm sargs_eff
+ PredefEvalType.boolred_profile id_solver lxm sargs_eff
| CondAct ->
- PredefEvalType.condact_profile lxm sargs_eff
+ PredefEvalType.condact_profile id_solver lxm sargs_eff
| _ -> raise Not_found
in
@@ -570,7 +605,7 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
*)
let mk_by_pos_op by_pos_op_eff =
CallByPosEff(flagit by_pos_op_eff lxm, OperEff vel_eff)
- in s, mk_by_pos_op (Eff.PREDEF_CALL(zemacro, sargs_eff))
+ in s, mk_by_pos_op (Eff.PREDEF_CALL(zemacro.it, sargs_eff))
and translate_by_name_op id_solver op =
match op.it with
@@ -619,8 +654,8 @@ and node_of_static_arg id_solver node_or_node_ident lxm =
| StaticArgNode(CALL_n ne) -> of_node id_solver ne
| StaticArgNode(Predef_n (op,sargs)) ->
- let sargs_eff = translate_predef_static_args id_solver op sargs lxm in
- PredefEvalType.make_node_exp_eff None op lxm sargs_eff
+ let sargs_eff = translate_predef_static_args id_solver op.it sargs lxm in
+ PredefEvalType.make_node_exp_eff id_solver None op.it lxm sargs_eff
| StaticArgNode(_) -> assert false
| StaticArgType _
@@ -732,11 +767,10 @@ and translate_predef_static_args
match sargs with
| [n; s] ->
let node_eff = node_of_static_arg id_solver n.it n.src in
- let node_arg =
- node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff
- in
+ (* OBSO *)
+ (* 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);
+ NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
ConstStaticArgEff(Ident.of_string "size", const_of_static_arg id_solver s.it s.src)
]
| _ -> raise (Compile_error(lxm, "bad arguments number for array iterator"))
@@ -754,13 +788,11 @@ and translate_predef_static_args
*)
let node_eff = node_of_static_arg id_solver n.it n.src in
- let node_arg =
- node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff
- in
+ (* let node_arg = node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff in *)
let dflt = const_of_static_arg id_solver d.it d.src in
[
- NodeStaticArgEff(Ident.of_string "node", node_arg, node_eff);
+ NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
ConstStaticArgEff(Ident.of_string "default", dflt)
]
| _ -> raise (Compile_error(lxm, "bad arguments number for condact macro"))
diff --git a/src/inline.ml b/src/inline.ml
index 14c502a8387332047e2b1c1dc6770a1093df297a..6b0c779c557ee984d68ba81605e99eba4ff97a63 100644
--- a/src/inline.ml
+++ b/src/inline.ml
@@ -90,8 +90,9 @@ let rec (inline_eq: Eff.node_env -> inline_acc -> Eff.eq_info srcflagged -> inl
for all i = 0, ..., c-1; (Y1[i], ... ,Yl[i]) = N(X_1[i], ... ,X_k[i])
*)
let (node,c) = match sargs with
- | [ConstStaticArgEff(_,Int_const_eff(c)) ; NodeStaticArgEff(_,_node_key, node)]
- | [NodeStaticArgEff(_,_node_key,node) ; ConstStaticArgEff(_,Int_const_eff(c))] ->
+ | [ConstStaticArgEff(_,Int_const_eff(c)) ; NodeStaticArgEff(_,_node_key)]
+ | [NodeStaticArgEff(_,_node_key) ; ConstStaticArgEff(_,Int_const_eff(c))] ->
+ let node = UglyStuff.node_exp_of_node_key node_env.global _node_key (Lxm.dummy "") in
node, c
| _ -> assert false (* todo: issue an error *)
in
@@ -160,8 +161,9 @@ let rec (inline_eq: Eff.node_env -> inline_acc -> Eff.eq_info srcflagged -> inl
(acc_i+1, Y1[i], ... ,Yl[i]) = N(acc_i,X_1[i], ... ,X_k[i])
*)
let (id,node,c) = match sargs with
- | [ConstStaticArgEff(_,Int_const_eff(c)) ; NodeStaticArgEff(id,_,node)]
- | [NodeStaticArgEff(id,_,node) ; ConstStaticArgEff(_,Int_const_eff(c))] ->
+ | [ConstStaticArgEff(_,Int_const_eff(c)) ; NodeStaticArgEff(id,_node_key)]
+ | [NodeStaticArgEff(id,_node_key) ; ConstStaticArgEff(_,Int_const_eff(c))] ->
+ let node = UglyStuff.node_exp_of_node_key node_env.global _node_key (Lxm.dummy "") in
id, node, c
| _ -> assert false (* todo: issue an error *)
in
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index e8e9088029eec3d3783d373d37f7f3c4ee2bd00d..28cf07fb782e1d6c0cdfde82d37637933740c21d 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -52,10 +52,14 @@ let (create : SyntaxTab.t -> t) =
fun tbl ->
let nodes_tbl = Hashtbl.create 0 in
let prov_nodes_tbl = Hashtbl.create 0 in
+(* GESTION DES OP PREDEF LAISSE A DESIRER !
+ 12/07 on garde cette beqyuille, mais faudra
+ sans doute revoir plus globalement ...
+*)
List.iter
(fun op ->
let op_str = Predef.op2string op in
- let op_eff = PredefEvalType.make_node_exp_eff None op (Lxm.dummy op_str) [] in
+ let op_eff = PredefEvalType.make_simple_node_exp_eff None op (Lxm.dummy op_str) in
let op_key = Predef.op_to_long op, [] in
Hashtbl.add nodes_tbl op_key (Eff.Checked op_eff);
Hashtbl.add prov_nodes_tbl op_key (Eff.Checked op_eff)
@@ -213,40 +217,44 @@ let (lookup_const_eff:(Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t ->
Ident.long -> Lxm.t -> Eff.const) =
lookup_x_eff "const ref " (fun k -> k)
-let (lookup_node_exp_eff:
- (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t ->
- Eff.node_key -> Lxm.t -> Eff.node_exp) =
- fun tbl key lxm ->
- try
+
+(*
+*)
+let lookup_node_exp_eff
+ (tbl: (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t)
+ (key: Eff.node_key)
+ (lxm: Lxm.t)
+: Eff.node_exp =
+ try
let node_exp = lookup_x_eff "node ref " (fun k -> fst k) tbl key lxm in
Verbose.printf ~flag:dbg
"#DBG: LazyCompiler.lookup_node_exp_eff: FOUND node key '%s'\n"
(Eff.string_of_node_key key)
;
node_exp
- with
- Not_found ->
- if fst (fst key) = "Lustre" then (
- let msg = (LicDump.string_of_node_key_iter key) ^ ": unknown Lustre operator. "^
- "\n*** Available operators in the current scope are:\n" ^
- (Hashtbl.fold (fun nk _ acc -> acc ^
- ("\t - "^ (LicDump.string_of_node_key_iter nk) ^ "\n")) tbl "")
- in
- raise (Compile_error(lxm, msg))
- )
- else (
- Verbose.exe ~flag:dbg (
- fun () ->
- Printf.fprintf stderr "#DBG: LazyCompiler.lookup_node_exp_eff: node key '%s' NOT FOUND\n"
- (Eff.string_of_node_key key);
+ with Not_found ->
+ (* 12/07 *)
+ if fst (fst key) = "Lustre" then (
+
+ let msg = (LicDump.string_of_node_key_iter key) ^ ": unknown Lustre operator. "^
+ "\n*** Available operators in the current scope are:\n" ^
+ (Hashtbl.fold (fun nk _ acc -> acc ^
+ ("\t - "^ (LicDump.string_of_node_key_iter nk) ^ "\n")) tbl "")
+ in
+ raise (Compile_error(lxm, msg))
+
+ ) else (
+ Verbose.exe ~flag:dbg (
+ fun () ->
+ Printf.fprintf stderr "#DBG: LazyCompiler.lookup_node_exp_eff: node key '%s' NOT FOUND\n"
+ (Eff.string_of_node_key key);
flush stderr
);
raise Not_found
- )
+ )
(* lookup_x_eff "node ref " (fun k -> fst k) *)
-
(** This function performs the identifier (idref) resolution,
i.e., when an ident is not explicitely prefixed by a module
name, we decide here to which module it belongs.
@@ -772,7 +780,7 @@ and node_check_do
id2node =
(fun id sargs lxm ->
(try
- let (node_id,sargs), inlist, outlist = lookup_node local_env id sargs lxm in
+ let (node_id,sargs) = Eff.lookup_node local_env id sargs lxm in
let node_id = Ident.idref_of_long node_id in
solve_node_idref this symbols provide_flag pack_name node_id sargs lxm
(* node_check this (node_id,[]) lxm *)
@@ -1022,18 +1030,21 @@ and node_check_do
| Alias({it= alias;src=lxm}) -> (
let aliased_node =
match alias with
- | Predef_n((Predef.NOR_n|Predef.DIESE_n), sargs) ->
- raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
-
- | Predef_n(predef_op, sargs) ->
- let sargs_eff =
- GetEff.translate_predef_static_args node_id_solver predef_op sargs lxm
- in
- let predef_op_eff =
- PredefEvalType.make_node_exp_eff
- (Some node_def.it.has_mem) predef_op lxm sargs_eff
- in
- predef_op_eff
+ | Predef_n(op, sargs) ->
+ let predef_op = op.it in
+ let _ = match predef_op with
+ | Predef.NOR_n | Predef.DIESE_n ->
+ raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
+ | _ -> ()
+ in
+ let sargs_eff =
+ GetEff.translate_predef_static_args node_id_solver predef_op sargs lxm
+ in
+ let predef_op_eff =
+ PredefEvalType.make_node_exp_eff node_id_solver
+ (Some node_def.it.has_mem) predef_op lxm sargs_eff
+ in
+ predef_op_eff
| CALL_n(node_alias) ->
GetEff.of_node node_id_solver node_alias
diff --git a/src/licDump.ml b/src/licDump.ml
index c104544c8fe2304b499d9deb6faa66e86bf9c787..0deb99cdf02f7700f40e0e5aa3518b2cc2323f38 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -234,7 +234,8 @@ and static_arg2string_bis (sa : Eff.static_arg) =
match sa with
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
- | NodeStaticArgEff (id, ((long, _sargs), _, _), _) ->
+ (* | NodeStaticArgEff (id, ((long, _sargs), _, _), _) -> *)
+ | NodeStaticArgEff (id, (long,_)) ->
sprintf "%s" (Ident.no_pack_string_of_long long)
(* for printing recursive node and iterators *)
@@ -242,7 +243,8 @@ and static_arg2string (sa : Eff.static_arg) =
match sa with
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
- | NodeStaticArgEff (id, ((long,sargs), _, _), _) ->
+ (* | NodeStaticArgEff (id, ((long,sargs), _, _), _) -> *)
+ | NodeStaticArgEff (id, (long,sargs)) ->
string_of_node_key_iter (long,sargs)
(* sprintf "%s" (dump_long long) *)
diff --git a/src/main.ml b/src/main.ml
index b798a22143c7f4d1612e8d61d512ad29670fe734..5e7346ff6f41524396e24580bbffbde3b21eff7a 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -63,6 +63,7 @@ let test_lex ( lexbuf ) = (
let lus_load lexbuf =
let tree = Parser.program Lexer.lexer lexbuf in
Name.update_fresh_var_prefix ();
+ (* ICI *)
SolveIdent.recognize_predef_op tree
diff --git a/src/parser.mly b/src/parser.mly
index 8d1373c65e82220d2b1bb547083e918d9d336601..b01dd885984738e2d432b1d95e4a086b91faa1c4 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -835,29 +835,29 @@ ClockExpr:
;
PredefOp: /* ebnf:print=short */
- TK_NOT { {src=$1; it=Predef_n(NOT_n,[])} }
+ TK_NOT { make_predef_posop $1 NOT_n }
| TK_FBY { {src=$1; it=FBY_n} }
| TK_PRE { {src=$1; it=PRE_n} }
| TK_CURRENT{ {src=$1; it=CURRENT_n} }
| TK_ARROW { {src=$1; it=ARROW_n} }
- | TK_AND { {src=$1; it=Predef_n(AND_n,[]) } }
- | TK_OR { {src=$1; it=Predef_n(OR_n,[]) } }
- | TK_XOR { {src=$1; it=Predef_n(XOR_n,[]) } }
- | TK_IMPL { {src=$1; it=Predef_n(IMPL_n,[]) } }
- | TK_EQ { {src=$1; it=Predef_n(EQ_n,[]) } }
- | TK_NEQ { {src=$1; it=Predef_n(NEQ_n,[]) } }
- | TK_LT { {src=$1; it=Predef_n(LT_n,[]) } }
- | TK_LTE { {src=$1; it=Predef_n(LTE_n,[]) } }
- | TK_GT { {src=$1; it=Predef_n(GT_n,[]) } }
- | TK_GTE { {src=$1; it=Predef_n(GTE_n,[]) } }
- | TK_DIV { {src=$1; it=Predef_n(DIV_n,[]) } }
- | TK_MOD { {src=$1; it=Predef_n(MOD_n,[]) } }
- | TK_MINUS { {src=$1; it=Predef_n(MINUS_n,[]) } }
- | TK_PLUS { {src=$1; it=Predef_n(PLUS_n,[]) } }
- | TK_SLASH { {src=$1; it=Predef_n(SLASH_n,[]) } }
- | TK_STAR { {src=$1; it=Predef_n(TIMES_n,[]) } }
- | TK_IF { {src=$1; it=Predef_n(IF_n,[]) } }
+ | TK_AND { make_predef_posop $1 AND_n }
+ | TK_OR { make_predef_posop $1 OR_n }
+ | TK_XOR { make_predef_posop $1 XOR_n }
+ | TK_IMPL { make_predef_posop $1 IMPL_n }
+ | TK_EQ { make_predef_posop $1 EQ_n }
+ | TK_NEQ { make_predef_posop $1 NEQ_n }
+ | TK_LT { make_predef_posop $1 LT_n }
+ | TK_LTE { make_predef_posop $1 LTE_n }
+ | TK_GT { make_predef_posop $1 GT_n }
+ | TK_GTE { make_predef_posop $1 GTE_n }
+ | TK_DIV { make_predef_posop $1 DIV_n }
+ | TK_MOD { make_predef_posop $1 MOD_n }
+ | TK_MINUS { make_predef_posop $1 MINUS_n }
+ | TK_PLUS { make_predef_posop $1 PLUS_n }
+ | TK_SLASH { make_predef_posop $1 SLASH_n }
+ | TK_STAR { make_predef_posop $1 TIMES_n }
+ | TK_IF { make_predef_posop $1 IF_n }
;
/* nothing to do here !!!
@@ -1107,13 +1107,13 @@ ExpressionList: Expression
Constant: /* ebnf:print=short */
TK_TRUE
- { (leafexp $1 (Predef_n(TRUE_n,[]))) }
+ { (leafexp_predef $1 TRUE_n) }
| TK_FALSE
- { (leafexp $1 (Predef_n(FALSE_n,[]))) }
+ { (leafexp_predef $1 FALSE_n) }
| IntConst
- { (leafexp $1 (Predef_n((ICONST_n (Lxm.id $1)),[]))) }
+ { (leafexp_predef $1 (ICONST_n (Lxm.id $1))) }
| RealConst
- { (leafexp $1 (Predef_n((RCONST_n (Lxm.id $1)),[]))) }
+ { (leafexp_predef $1 ((RCONST_n (Lxm.id $1)))) }
;
IntConst: /* ebnf:print=ignore */
diff --git a/src/parserUtils.ml b/src/parserUtils.ml
index d5bab635807fd7fe3c98a6238448a354d2f15358..b29abc93840bd9639694e18ec891a7b21a2a74fb 100644
--- a/src/parserUtils.ml
+++ b/src/parserUtils.ml
@@ -120,22 +120,43 @@ let flat_twice_flagged_list
(** Utilitaries to build [val_exp] *)
-let leafexp lxm op = CallByPos({src = lxm ; it = op }, Oper [])
+let make_predef_posop lxm op =
+ let op = flagit op lxm in
+ {src = lxm ; it = Predef_n (op,[]) }
-let unexp lxm op e1 = CallByPos( {src = lxm ; it = op }, Oper [e1] )
-let unexp_predef lxm op e1 = CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper [e1] )
+let leafexp lxm op =
+ CallByPos({src = lxm ; it = op }, Oper [])
-let binexp lxm op e1 e2 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2] )
-let binexp_predef lxm op e1 e2 = CallByPos( {src = lxm ; it = Predef_n (op,[]) },
- Oper [e1 ; e2] )
+let leafexp_predef lxm op =
+ let op = flagit op lxm in
+ CallByPos({src = lxm ; it = Predef_n (op,[]) }, Oper [])
+
+let unexp lxm op e1 =
+ CallByPos( {src = lxm ; it = op }, Oper [e1] )
+
+let unexp_predef lxm op e1 =
+ let op = flagit op lxm in
+ CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper [e1] )
+
+let binexp lxm op e1 e2 =
+ CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2] )
+
+let binexp_predef lxm op e1 e2 =
+ let op = flagit op lxm in
+ CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper [e1 ; e2] )
let ternexp lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2; e3] )
-let ternexp_predef lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = Predef_n (op,[]) },
- Oper [e1 ; e2; e3] )
-let naryexp lxm op elst = CallByPos( {src = lxm ; it = op }, Oper elst )
-let naryexp_predef lxm op elst = CallByPos( {src = lxm ; it = Predef_n (op,[]) },
- Oper elst )
+let ternexp_predef lxm op e1 e2 e3 =
+ let op = flagit op lxm in
+ CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper [e1 ; e2; e3] )
+
+let naryexp lxm op elst =
+ CallByPos( {src = lxm ; it = op }, Oper elst )
+
+let naryexp_predef lxm op elst =
+ let op = flagit op lxm in
+ CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper elst )
let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )
@@ -445,11 +466,10 @@ let (threat_slice_start : Lxm.t -> val_exp -> val_exp option -> slice_info srcfl
let int_to_val_exp istr =
try
ignore (int_of_string istr);
- CallByPos(flagit (Predef_n(ICONST_n (Ident.of_string(istr)),[])) lxm,
- Oper [])
+ let ic = flagit (ICONST_n (Ident.of_string(istr))) lxm in
+ CallByPos(flagit (Predef_n (ic, [])) lxm, Oper [])
with _ ->
- CallByPos(flagit (IDENT_n (Ident.idref_of_string(istr))) lxm,
- Oper [])
+ CallByPos(flagit (IDENT_n (Ident.idref_of_string(istr))) lxm, Oper [])
in
match Str.split (Str.regexp (Str.quote "..")) str with
| [first] ->
diff --git a/src/predef.ml b/src/predef.ml
index e69e48f9b78f305e5d8bea35939e9586f00e1415..ff77394705ac520d37fd329edb93f0d0b0ee317b 100644
--- a/src/predef.ml
+++ b/src/predef.ml
@@ -62,6 +62,7 @@ type op =
| BoolRed
(* can occur into an array iterator *)
+(* GESTION DES OP PREDEF LAISSE A DESIRER *)
let iterable_op = [
NOT_n; REAL2INT_n; INT2REAL_n; AND_n; OR_n; XOR_n; IMPL_n;
DIV_n; MOD_n; IUMINUS_n; IMINUS_n; IPLUS_n; ISLASH_n; ITIMES_n;
@@ -230,6 +231,12 @@ let (op_to_long : op -> Ident.long) =
Ident.make_long
(Ident.pack_name_of_string "Lustre")
(Ident.of_string (op2string_long op))
+
+let (op_to_idref : op -> Ident.idref) =
+ fun op ->
+ Ident.make_idref
+ (Ident.pack_name_of_string "Lustre")
+ (Ident.of_string (op2string_long op))
(*********************************************************************************)
(* Automatically generate the latex documentation associated to predefined
diff --git a/src/predefEvalClock.ml b/src/predefEvalClock.ml
index 851dec63d0fc2aa16ffcecf8d2f89e0c29afdec1..7bcdad94b89b59a43fc5be877e2e6ed0133f5331 100644
--- a/src/predefEvalClock.ml
+++ b/src/predefEvalClock.ml
@@ -36,31 +36,35 @@ let rec fill x n = if n > 0 then (x::(fill x (n-1))) else []
(* ICI : je comprends rien à ce que ca fait ??? *)
-let condact_clock_profile lxm sargs s clks =
- let (_, lto) = PredefEvalType.condact_profile lxm sargs in
+let condact_clock_profile id_solver lxm sargs s clks =
+ let (_, lto) = PredefEvalType.condact_profile id_solver lxm sargs in
let clks = List.flatten clks in
fill (List.hd clks) (List.length lto), s
-let fillred_clock_profile lxm sargs s clks =
- let (_, lto) = PredefEvalType.fillred_profile lxm sargs in
+let fillred_clock_profile id_solver lxm sargs s clks =
+ let (_, lto) = PredefEvalType.fillred_profile id_solver lxm sargs in
let clks = List.flatten clks in
fill (List.hd clks) (List.length lto), s
-let map_clock_profile lxm sargs s clks =
- let (_, lto) = PredefEvalType.map_profile lxm sargs in
+let map_clock_profile id_solver lxm sargs s clks =
+ let (_, lto) = PredefEvalType.map_profile id_solver lxm sargs in
let clks = List.flatten clks in
fill (List.hd clks) (List.length lto), s
-let boolred_clock_profile lxm sargs s clks =
- let (_, lto) = PredefEvalType.boolred_profile lxm sargs in
+let boolred_clock_profile id_solver lxm sargs s clks =
+ let (_, lto) = PredefEvalType.boolred_profile id_solver lxm sargs in
let clks = List.flatten clks in
fill (List.hd clks) (List.length lto), s
(* This table contains the clock profile of predefined operators *)
-let (f: op -> Lxm.t -> Eff.static_arg list -> clocker) =
- fun op lxm sargs s ->
+let f
+ (id_solver: Eff.id_solver)
+ (op: op)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: clocker = fun s ->
match op with
| TRUE_n | FALSE_n | ICONST_n _ | RCONST_n _ ->
constant_profile (Predef.op2string op) s
@@ -75,10 +79,10 @@ let (f: op -> Lxm.t -> Eff.static_arg list -> clocker) =
-> op_profile s
| IF_n -> if_clock_profile lxm sargs s
- | Red | Fill | FillRed -> fillred_clock_profile lxm sargs s
- | Map -> map_clock_profile lxm sargs s
- | BoolRed -> boolred_clock_profile lxm sargs s
- | CondAct -> condact_clock_profile lxm sargs s
+ | Red | Fill | FillRed -> fillred_clock_profile id_solver lxm sargs s
+ | Map -> map_clock_profile id_solver lxm sargs s
+ | BoolRed -> boolred_clock_profile id_solver lxm sargs s
+ | CondAct -> condact_clock_profile id_solver lxm sargs s
diff --git a/src/predefEvalClock.mli b/src/predefEvalClock.mli
index 0cf63d80854b6bd7e424e09d94e050afe8d0c471..8162e6fe63277cd424dba1be5c27dd6c93448ff4 100644
--- a/src/predefEvalClock.mli
+++ b/src/predefEvalClock.mli
@@ -6,4 +6,4 @@ type clocker = UnifyClock.subst -> Eff.id_clock list list ->
Eff.id_clock list * UnifyClock.subst
-val f: Predef.op -> Lxm.t -> Eff.static_arg list -> clocker
+val f: Eff.id_solver -> Predef.op -> Lxm.t -> Eff.static_arg list -> clocker
diff --git a/src/predefEvalConst.ml b/src/predefEvalConst.ml
index aa05575044c2f5b12a84b76d08ac1aca32445e81..02c0c584faba1fb77a3a3c8f68e6d6cb7678b3e0 100644
--- a/src/predefEvalConst.ml
+++ b/src/predefEvalConst.ml
@@ -120,11 +120,15 @@ let (boolred_evaluator : int -> int -> const_evaluator) =
(* exported *)
-let (f: op -> Lxm.t -> Eff.static_arg list -> const_evaluator) =
- fun op lxm sargs ll ->
+let f
+ (id_solver: Eff.id_solver)
+ (op: op)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: const_evaluator = fun ll ->
(* we first check the type so that we do not need to check it during the const
evaluation *)
- ignore (PredefEvalType.f op lxm sargs (List.map (List.map Eff.type_of_const) ll));
+ ignore (PredefEvalType.f id_solver op lxm sargs (List.map (List.map Eff.type_of_const) ll));
match op with
| TRUE_n -> sb_evaluator true ll
| FALSE_n -> sb_evaluator false ll
diff --git a/src/predefEvalConst.mli b/src/predefEvalConst.mli
index 79d4ad274556ad9f75a66b1bceea6a292bd8d78c..4fa8cefea59aba627cf9e4635bee93ae9b167942 100644
--- a/src/predefEvalConst.mli
+++ b/src/predefEvalConst.mli
@@ -10,6 +10,6 @@ val arity_error_const : Eff.const list -> string -> 'a
type const_evaluator = Eff.const evaluator
(* That function says how to statically evaluate constants *)
-val f:
+val f: Eff.id_solver ->
Predef.op -> Lxm.t -> Eff.static_arg list -> const_evaluator
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index c8340d23888b220d526816c9a46d9b981466d10c..92d4438e836ad16c36e13c879e62d5549d6e259a 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -84,26 +84,25 @@ 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_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
-
- | [
- NodeStaticArgEff(_,((n,_), inlist, outlist), _);
- ConstStaticArgEff(_, Abstract_const_eff(l,_,Int_const_eff c, true))] ->
- n, inlist, outlist, c
-
- | [NodeStaticArgEff(_,_,_);
- ConstStaticArgEff(_, zcl) ]
- ->
- let msg = "immediate integer expected, but get \""
- ^ (LicDump.string_of_const_eff zcl)
- ^ "\"\n"
- in raise (Compile_error(lxm, msg))
- | _ ->
+let get_node_and_int_const
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: (Eff.node_key * int) =
+
+ match sargs with
+ | [ NodeStaticArgEff (_,nk); ConstStaticArgEff carg ] -> (
+ let c = match carg with
+ | (_, Int_const_eff c) -> c
+ | (_, Abstract_const_eff(_,_,Int_const_eff c, true)) -> c
+ | (_, zcl) ->
+ let msg = "immediate integer expected, but get \""
+ ^ (LicDump.string_of_const_eff zcl)
+ ^ "\"\n"
+ in raise (Compile_error(lxm, msg))
+ in
+ (nk, c)
+ )
+ | _ ->
let msg = "*** an integer and a node are expected.\n" in
raise (Compile_error(lxm, msg))
@@ -114,20 +113,29 @@ Typers for predef macros/iterators
let get_id_type vi = vi.var_name_eff, vi.var_type_eff
-let condact_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
+let condact_profile
+ (id_solver: Eff.id_solver)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: Eff.node_profile =
try
-(* 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 =
+(*--------------------------------------------------------------------
+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
+---------------------------------------------------------------------*)
+ let nk, dflt =
match sargs with
- | [NodeStaticArgEff(_,((n,_), inlist, outlist), _);
- ConstStaticArgEff(_,dflt)] -> n, inlist, outlist, dflt
+ | [NodeStaticArgEff(_,nk) ; ConstStaticArgEff(_,dflt)] -> nk, dflt
| _ -> assert false
in
+ (* recherche le profil de nk ... *)
+ let ne = UglyStuff.node_exp_of_node_key id_solver nk lxm 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
@@ -147,44 +155,66 @@ with
| EvalType_error msg -> raise (Compile_error(lxm, "type error: "^msg))
-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
+let map_profile
+ (id_solver: Eff.id_solver)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: Eff.node_profile =
+(*--------------------------------------------------------------------
+MAP
+----------------------------------------------------------------------
+ Given :
+ - A node n of type: a_1 * ... * a_n -> b_1 * ... * b_k
+ - A (int) const c
+Gen a node of type : a_1^c * ... * a_n^c -> b_1^c * ... * b_k^c
+--------------------------------------------------------------------*)
+ let (nk, c) = get_node_and_int_const lxm sargs in
+ (* recherche le profil de nk ... *)
+ let ne = UglyStuff.node_exp_of_node_key id_solver nk lxm in
+ let inlist = ne.inlist_eff in
+ let outlist = ne.outlist_eff 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 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])
-
- returns the profile:
- tau * tau_1^c * ... * tau_n^c -> tau * teta_1^c * ... * teta_l^c
- *)
- 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
- let lto = (get_id_type (List.hd outlist))::
- type_to_array_type (List.tl outlist) c in
- let (id1, t1) = List.hd lti and (id2, t2) = List.hd lto in
- let res =
- if t1 = t2 then (lti,lto) else
- (* if they are not equal, they migth be unifiable *)
- match UnifyType.f [t1] [t2] with
- | Equal -> (lti,lto)
- | Unif t ->
- (List.map (fun (id,tid) -> id, subst_type t tid) lti,
- List.map (fun (id,tid) -> id, subst_type t tid) lto)
- | Ko(msg) -> raise (Compile_error(lxm, msg))
- in
- res
+let fillred_profile
+ (id_solver: Eff.id_solver)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: Eff.node_profile =
+(*--------------------------------------------------------------------
+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
+--------------------------------------------------------------------*)
+
+ let (nk, c) = get_node_and_int_const lxm sargs in
+ (* recherche le profil de nk ... *)
+ let ne = UglyStuff.node_exp_of_node_key id_solver nk lxm in
+ let inlist = ne.inlist_eff in
+ let outlist = ne.outlist_eff in
+
+ let _ = assert(inlist <> [] && outlist <> []) in
+ let lti = (get_id_type (List.hd inlist))::
+ type_to_array_type (List.tl inlist) c in
+ let lto = (get_id_type (List.hd outlist))::
+ type_to_array_type (List.tl outlist) c in
+ let (id1, t1) = List.hd lti and (id2, t2) = List.hd lto in
+ let res =
+ if t1 = t2 then (lti,lto) else
+ (* if they are not equal, they migth be unifiable *)
+ match UnifyType.f [t1] [t2] with
+ | Equal -> (lti,lto)
+ | Unif t ->
+ (List.map (fun (id,tid) -> id, subst_type t tid) lti,
+ List.map (fun (id,tid) -> id, subst_type t tid) lto)
+ | Ko(msg) -> raise (Compile_error(lxm, msg))
+ in
+ res
(* let fill_profile = fillred_profile *)
(* Given
@@ -206,7 +236,11 @@ let fillred_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile
returns the profile bool^k -> bool
*)
-let boolred_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile =
+let boolred_profile
+ (id_solver: Eff.id_solver)
+ (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
@@ -221,8 +255,18 @@ let boolred_profile (lxm: Lxm.t) (sargs: Eff.static_arg list) : Eff.node_profile
(*---------------------------------------------------------------------*)
-let (op2profile : Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_profile) =
- fun op lxm sargs ->
+let op2profile
+(* BEQUILLE *)
+ (id_solver_opt: Eff.id_solver option)
+ (op: Predef.op)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: Eff.node_profile =
+ let id_solver () =
+ match id_solver_opt with
+ | Some s -> s
+ | None -> assert false
+ in
let res =
match op with
| TRUE_n | FALSE_n -> b_profile
@@ -240,10 +284,10 @@ let (op2profile : Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_profile)
| MINUS_n | PLUS_n | TIMES_n | SLASH_n -> ooo_profile
| RMINUS_n | RPLUS_n | RTIMES_n | RSLASH_n -> rrr_profile
| DIV_n | MOD_n | IMINUS_n | IPLUS_n | ISLASH_n | ITIMES_n -> iii_profile
- | Red | Fill | FillRed -> fillred_profile lxm sargs
- | Map -> map_profile lxm sargs
- | BoolRed -> boolred_profile lxm sargs
- | CondAct -> condact_profile lxm sargs
+ | Red | Fill | FillRed -> fillred_profile (id_solver ()) lxm sargs
+ | Map -> map_profile (id_solver ()) lxm sargs
+ | BoolRed -> boolred_profile (id_solver ()) lxm sargs
+ | CondAct -> condact_profile (id_solver ()) lxm sargs
| NOR_n | DIESE_n -> assert false
(* XXX The current representation of node_profile prevent us
@@ -256,16 +300,21 @@ let (op2profile : Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_profile)
*)
in
res
+
(* exported *)
+(* VERSION GÉNÉRALE, valable
+ pour les MACROS, et qui necessite donc un Eff.id_solver
+*)
let make_node_exp_eff
+ (id_solver: Eff.id_solver)
(has_mem: bool option)
(op: op)
(lxm: Lxm.t)
(sargs: Eff.static_arg list)
- : Eff.node_exp =
+: Eff.node_exp =
let id = Predef.op_to_long op in
- let (lti,lto) = op2profile op lxm sargs in
+ let (lti,lto) = op2profile (Some id_solver) op lxm sargs in
let i = ref 0 in
(* let is_polymorphic = ref false in *)
let to_var_info_eff nature (vid, te) =
@@ -301,9 +350,59 @@ let make_node_exp_eff
in
res
+(* VERSION SIMPLE, valable
+ UNIQUEMENT pour les NON MACROS
+*)
+let make_simple_node_exp_eff
+ (has_mem: bool option)
+ (op: op)
+ (lxm: Lxm.t)
+: Eff.node_exp =
+
+ let id = Predef.op_to_long op in
+ let (lti,lto) = op2profile None op lxm [] in
+ let i = ref 0 in
+ (* let is_polymorphic = ref false in *)
+ let to_var_info_eff nature (vid, te) =
+ let res =
+ (* if Eff.is_polymorphic te then is_polymorphic := true ; *)
+ {
+ var_name_eff = vid;
+ var_nature_eff = nature;
+ var_number_eff = !i;
+ var_type_eff = te;
+ var_clock_eff = vid,BaseEff;
+ }
+ in
+ incr i;
+ res
+ in
+ let inlist_eff = List.map (to_var_info_eff SyntaxTreeCore.VarInput) lti in
+ let outlist_eff = (i:=0;List.map (to_var_info_eff SyntaxTreeCore.VarOutput) lto) in
+ let res =
+ {
+ node_key_eff = id,[] ;
+ inlist_eff = inlist_eff;
+ outlist_eff = outlist_eff;
+ loclist_eff = None;
+ def_eff = ExternEff;
+ has_mem_eff = (match has_mem with Some b -> b | None -> true);
+ is_safe_eff = true;
+ (* is_polym_eff = *)
+(* List.exists (fun vi -> Eff.is_polymorphic vi.var_type_eff) inlist_eff || *)
+(* List.exists (fun vi -> Eff.is_polymorphic vi.var_type_eff) outlist_eff *)
+ (* !is_polymorphic *)
+ }
+ in
+ res
+
(* exported *)
-let (f : op -> Lxm.t -> Eff.static_arg list -> typer) =
- fun op lxm sargs ll ->
+let f
+ (id_solver: Eff.id_solver)
+ (op: op)
+ (lxm: Lxm.t)
+ (sargs: Eff.static_arg list)
+: typer = fun ll ->
match op with
| IF_n -> (
(* VERRUE 1 *)
@@ -327,7 +426,7 @@ let (f : op -> Lxm.t -> Eff.static_arg list -> typer) =
[Bool_type_eff]
| _ ->
(* general case *)
- let node_eff = make_node_exp_eff (Some false) op lxm sargs in
+ let node_eff = make_node_exp_eff id_solver (Some false) op lxm sargs in
let lti = List.map (fun v -> v.var_type_eff) node_eff.inlist_eff
and lto = List.map (fun v -> v.var_type_eff) node_eff.outlist_eff in
let l = List.flatten ll in
diff --git a/src/predefEvalType.mli b/src/predefEvalType.mli
index 3b237dc6d795859d7bfe11ed22c71542d666dd09..584061e3d18f8c09cff4662d65f7129e3ef2ca46 100644
--- a/src/predefEvalType.mli
+++ b/src/predefEvalType.mli
@@ -12,15 +12,29 @@ val raise_type_error : Eff.type_ list -> Eff.type_ list -> string -> 'a
and a list of types, This function checks that the provided types are ok, and
returns the list of the operator output types.
*)
-val f : Predef.op -> Lxm.t -> Eff.static_arg list -> typer
+val f : Eff.id_solver -> Predef.op -> Lxm.t -> Eff.static_arg list -> typer
(* Does not work for NOR_n and DIESE_n! *)
+(* PIS ALLER : 2 versions
+ - une pour les macros, qui nécessite un Eff.id_solver pour traiter les Eff.static_arg list
+ - l'autre pour les noeuds simple qui peut être utilisée statiquement
+*)
val make_node_exp_eff :
- bool option -> Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_exp
+ Eff.id_solver -> bool option -> Predef.op -> Lxm.t -> Eff.static_arg list -> Eff.node_exp
+
+val make_simple_node_exp_eff :
+ bool option -> Predef.op -> Lxm.t -> Eff.node_exp
+
-(* 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
+
+
+(* TODO : rather ugly, one type-checker per macro !
+Un env est necessaire pour retrouver le type des
+noeuds appeles, mais ca ne dvrait pas etre fait
+via un id_solver (cf. EvalType qui a le mem pb
+*)
+val fillred_profile : Eff.id_solver -> Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val map_profile : Eff.id_solver -> Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val boolred_profile : Eff.id_solver -> Lxm.t -> Eff.static_arg list -> Eff.node_profile
+val condact_profile : Eff.id_solver -> Lxm.t -> Eff.static_arg list -> Eff.node_profile
diff --git a/src/solveIdent.ml b/src/solveIdent.ml
index 3417d2a4e184ae8f8da74b91ba93438e93571edd..5276cb9687379c50a9401ce98ed00a8c73055515 100644
--- a/src/solveIdent.ml
+++ b/src/solveIdent.ml
@@ -17,6 +17,8 @@ open Lxm
let flag f x_flg = Lxm.flagit (f x_flg.it) x_flg.src
+let flag2 f x_flg = Lxm.flagit (f x_flg) x_flg.src
+
let fopt f = function None -> None | Some x -> Some (f x)
@@ -60,36 +62,37 @@ and r_by_name_static_arg (id,arg) =
| StaticArgIdent(idref) -> (
match get_predef idref with
| None -> StaticArgIdent idref
- | Some predef -> StaticArgNode (Predef_n (predef,[]))
+ | Some predef -> StaticArgNode (Predef_n (flagit predef arg.src,[]))
)
| StaticArgConst(ve) -> StaticArgConst(r_val_exp ve)
| StaticArgType(te) -> StaticArgType(te)
- | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op by_pos_op)
+ | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op (flagit by_pos_op arg.src))
in
id, Lxm.flagit arg_it arg.src
and r_static_arg arg =
- match arg with
+ match arg.it with
| StaticArgIdent(idref) -> (
match get_predef idref with
| None -> StaticArgIdent idref
- | Some predef -> StaticArgNode (Predef_n (predef,[]))
+ | Some predef -> StaticArgNode (Predef_n (flagit predef arg.src,[]))
)
| StaticArgConst(ve) -> StaticArgConst(r_val_exp ve)
| StaticArgType(te) -> StaticArgType(te)
- | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op by_pos_op)
+ | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op (flagit by_pos_op arg.src))
-and r_by_pos_op = function
+and r_by_pos_op arg =
+ match arg.it with
| Predef_n(op,args) -> Predef_n(op,args) (* assert false *)
| CALL_n { src=lxm;it=(idref,sargs) } -> (
match get_predef idref with
| None -> CALL_n { src=lxm;it= r_node_exp (idref,sargs) }
- | Some op -> Predef_n (op, List.map (flag r_static_arg) sargs)
+ | Some op -> Predef_n (flagit op arg.src, List.map (flag2 r_static_arg) sargs)
)
| IDENT_n(idref) -> (
match get_predef idref with
| None -> IDENT_n(idref)
- | Some op -> Predef_n (op,[])
+ | Some op -> Predef_n (flagit op arg.src,[])
)
| ARRAY_ACCES_n(val_exp) -> ARRAY_ACCES_n(r_val_exp val_exp)
| ARRAY_SLICE_n(slice_info) -> ARRAY_SLICE_n(r_slice_info slice_info)
@@ -97,7 +100,7 @@ and r_by_pos_op = function
| x -> x
and r_node_exp (idref, sargs) =
- (idref, List.map (flag r_static_arg) sargs)
+ (idref, List.map (flag2 r_static_arg) sargs)
and r_slice_info si = {
@@ -108,7 +111,7 @@ and r_slice_info si = {
and r_val_exp = function
| CallByPos (by_pos_op, Oper vel) ->
- CallByPos(flag r_by_pos_op by_pos_op, Oper (List.map r_val_exp vel))
+ CallByPos(flag2 r_by_pos_op by_pos_op, Oper (List.map r_val_exp vel))
| CallByName(by_name_op, args) ->
CallByName(by_name_op, List.map (fun (id, ve) -> id, r_val_exp ve) args)
@@ -150,7 +153,7 @@ and r_node_def = function
| Extern -> Extern
| Abstract -> Abstract
| Body(node_body) -> Body(r_node_body node_body)
- | Alias(by_pos_op) -> Alias(flag r_by_pos_op by_pos_op)
+ | Alias(by_pos_op) -> Alias(flag2 r_by_pos_op by_pos_op)
and r_packbody pb =
Hashtbl.iter
diff --git a/src/syntaxTreeCore.ml b/src/syntaxTreeCore.ml
index 071a608417e53dbafae9c40f76a953779e741ab7..52918dcb63d40e0dc7f131c3b6e6e419397c6332 100644
--- a/src/syntaxTreeCore.ml
+++ b/src/syntaxTreeCore.ml
@@ -88,7 +88,7 @@ and slice_info = {
and by_pos_op =
(* zeroaire *)
- | Predef_n of Predef.op * static_arg srcflagged list (* e.g., map<<toto,3>> *)
+ | Predef_n of Predef.op srcflagged * static_arg srcflagged list (* e.g., map<<toto,3>> *)
| CALL_n of node_exp srcflagged (* e.g., a_node<<xx>> *)
| IDENT_n of Ident.idref (* constant or variable *)
diff --git a/src/syntaxTreeDump.ml b/src/syntaxTreeDump.ml
index d0e04f4bc2bde5a154db7fbfa824f8849b16819a..36bc111020d93113d383432befaaaefc836251e8 100644
--- a/src/syntaxTreeDump.ml
+++ b/src/syntaxTreeDump.ml
@@ -21,7 +21,7 @@ let (op2string : SyntaxTreeCore.by_pos_op -> string) =
fun op ->
match op with
(* unaires *)
- | Predef_n(op,sargs) -> (Predef.op2string op) ^
+ | Predef_n(op,sargs) -> (Predef.op2string op.it) ^
(if sargs = [] then "" else
"<<" ^ (String.concat ", " (List.map static_arg_to_string sargs)) ^ ">>")
| (PRE_n ) -> "pre"
@@ -380,54 +380,59 @@ and dump_val_exp_list (os : formatter) (xl: val_exp list) = (
and dump_by_pos_exp (os: Format.formatter) (oper: by_pos_op) (pars: operands) =
(
match (oper, pars) with
- (Predef_n (TRUE_n,_), Oper []) -> dump_leaf_exp os "true"
- | (Predef_n (FALSE_n,_), Oper []) -> dump_leaf_exp os "false"
- | (Predef_n (ICONST_n s, _), Oper []) -> dump_leaf_exp os (Ident.to_string s)
- | (Predef_n (RCONST_n s, _), Oper []) -> dump_leaf_exp os (Ident.to_string s)
| (IDENT_n id,Oper []) -> dump_leaf_exp os (Ident.string_of_idref id)
- (* unaires *)
- | (Predef_n (NOT_n,_), Oper [p0]) -> dump_unary_exp os "not" p0
- | (Predef_n (UMINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
- | (Predef_n (RUMINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
- | (Predef_n (IUMINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
| (PRE_n, Oper [p0]) -> dump_unary_exp os "pre" p0
| (CURRENT_n, Oper [p0]) -> dump_unary_exp os "current" p0
- | (Predef_n (REAL2INT_n,_), Oper [p0]) -> dump_unary_exp os "int" p0
- | (Predef_n (INT2REAL_n,_), Oper [p0]) -> dump_unary_exp os "real" p0
- (* binaires *)
| (ARROW_n, Oper [p0;p1]) -> dump_binary_exp os "->" p0 p1
| (FBY_n, Oper [p0;p1]) -> dump_binary_exp os "fby" p0 p1
| (WHEN_n _, Oper [p0;p1]) -> dump_binary_exp os "when" p0 p1
- | (Predef_n (AND_n,_), Oper [p0;p1]) -> dump_binary_exp os "and" p0 p1
- | (Predef_n (OR_n,_), Oper [p0;p1]) -> dump_binary_exp os "or" p0 p1
- | (Predef_n (XOR_n,_), Oper [p0;p1]) -> dump_binary_exp os "xor" p0 p1
- | (Predef_n (IMPL_n,_), Oper [p0;p1]) -> dump_binary_exp os "=>" p0 p1
- | (Predef_n (EQ_n,_), Oper [p0;p1]) -> dump_binary_exp os "=" p0 p1
- | (Predef_n (NEQ_n,_), Oper [p0;p1]) -> dump_binary_exp os "<>" p0 p1
- | (Predef_n (LT_n,_), Oper [p0;p1]) -> dump_binary_exp os "<" p0 p1
- | (Predef_n (LTE_n,_), Oper [p0;p1]) -> dump_binary_exp os "<=" p0 p1
- | (Predef_n (GT_n,_), Oper [p0;p1]) -> dump_binary_exp os ">" p0 p1
- | (Predef_n (GTE_n,_), Oper [p0;p1]) -> dump_binary_exp os ">=" p0 p1
- | (Predef_n (DIV_n,_), Oper [p0;p1]) -> dump_binary_exp os "div" p0 p1
- | (Predef_n (MOD_n,_), Oper [p0;p1]) -> dump_binary_exp os "mod" p0 p1
- | (Predef_n (MINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
- | (Predef_n (RMINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
- | (Predef_n (IMINUS_n,_), Oper [p0]) -> dump_unary_exp os "-" p0
- | (Predef_n (PLUS_n,_), Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
- | (Predef_n (RPLUS_n,_), Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
- | (Predef_n (IPLUS_n,_), Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
- | (Predef_n (SLASH_n,_), Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
- | (Predef_n (RSLASH_n,_), Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
- | (Predef_n (ISLASH_n,_), Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
- | (Predef_n (TIMES_n,_), Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
- | (Predef_n (RTIMES_n,_), Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
- | (Predef_n (ITIMES_n,_), Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+
+ | (Predef_n (x,_), _) -> (
+ match (x.it, pars) with
+ | (TRUE_n, Oper []) -> dump_leaf_exp os "true"
+ | (FALSE_n, Oper []) -> dump_leaf_exp os "false"
+ | (ICONST_n s, Oper []) -> dump_leaf_exp os (Ident.to_string s)
+ | (RCONST_n s, Oper []) -> dump_leaf_exp os (Ident.to_string s)
+ (* unaires *)
+ | (NOT_n, Oper [p0]) -> dump_unary_exp os "not" p0
+ | (UMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (RUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (IUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (REAL2INT_n, Oper [p0]) -> dump_unary_exp os "int" p0
+ | (INT2REAL_n, Oper [p0]) -> dump_unary_exp os "real" p0
+ (* binaires *)
+ | (AND_n, Oper [p0;p1]) -> dump_binary_exp os "and" p0 p1
+ | (OR_n, Oper [p0;p1]) -> dump_binary_exp os "or" p0 p1
+ | (XOR_n, Oper [p0;p1]) -> dump_binary_exp os "xor" p0 p1
+ | (IMPL_n, Oper [p0;p1]) -> dump_binary_exp os "=>" p0 p1
+ | (EQ_n, Oper [p0;p1]) -> dump_binary_exp os "=" p0 p1
+ | (NEQ_n, Oper [p0;p1]) -> dump_binary_exp os "<>" p0 p1
+ | (LT_n, Oper [p0;p1]) -> dump_binary_exp os "<" p0 p1
+ | (LTE_n, Oper [p0;p1]) -> dump_binary_exp os "<=" p0 p1
+ | (GT_n, Oper [p0;p1]) -> dump_binary_exp os ">" p0 p1
+ | (GTE_n, Oper [p0;p1]) -> dump_binary_exp os ">=" p0 p1
+ | (DIV_n, Oper [p0;p1]) -> dump_binary_exp os "div" p0 p1
+ | (MOD_n, Oper [p0;p1]) -> dump_binary_exp os "mod" p0 p1
+ | (MINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (RMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (IMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (PLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (RPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (IPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (SLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (RSLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (ISLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (TIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (RTIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (ITIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (IF_n, Oper [p0;p1;p2]) -> dump_ternary_exp os "if" "then" "else" p0 p1 p2
+ | (NOR_n, Oper pl) -> dump_nary_exp os "nor" pl
+ | (DIESE_n, Oper pl) -> dump_nary_exp os "#" pl
+ | (_,_) -> assert false
+ )
| (HAT_n, Oper [p0;p1]) -> dump_binary_exp os "^" p0 p1
| (CONCAT_n, Oper [p0;p1]) -> dump_binary_exp os "|" p0 p1
- | (Predef_n (IF_n,_), Oper [p0;p1;p2]) -> dump_ternary_exp os "if" "then" "else" p0 p1 p2
| (WITH_n(_), Oper [p0;p1;p2]) -> dump_ternary_exp os "with" "then" "else" p0 p1 p2
- | (Predef_n (NOR_n,_), Oper pl) -> dump_nary_exp os "nor" pl
- | (Predef_n (DIESE_n,_), Oper pl) -> dump_nary_exp os "#" pl
| (TUPLE_n, Oper pl) -> dump_nary_exp os "" pl
| (CALL_n s, Oper pl) -> fprintf os "%a(@,%a@,)"
dump_node_exp s.it dump_val_exp_list pl
@@ -439,7 +444,6 @@ and dump_by_pos_exp (os: Format.formatter) (oper: by_pos_op) (pars: operands) =
| (STRUCT_ACCESS_n fld, Oper [p0]) -> fprintf os "%a.%s"
dump_val_exp p0 (Ident.to_string fld)
- | (Predef_n (_,_),_) -> assert false
(* | (ITERATOR_n _, _) -> assert false *)
| (MERGE_n _,_) -> assert false