diff --git a/src/compiledData.ml b/src/compiledData.ml
index 3485d894a0a5b4ab46c4ab7bf249b49c8a5cdde7..472ca6bd4b15941112c9e6dd8864933aff0ebeb0 100644
--- a/src/compiledData.ml
+++ b/src/compiledData.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/08/2008 (at 10:17) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 15:40) by Erwan Jahier> *)
(**
@@ -267,6 +267,7 @@ and node_exp_eff = {
def_eff : node_def_eff;
has_mem_eff : bool;
is_safe_eff : bool;
+ lxm : Lxm.t;
}
and node_def_eff =
@@ -421,6 +422,21 @@ let (var_eff_are_compatible : var_info_eff -> var_info_eff -> bool) =
let (make_simple_node_key : Ident.long -> node_key) =
fun nkey -> (nkey, [])
+let rec (subst_type : type_eff -> type_eff -> type_eff) =
+ fun t teff_ext -> match teff_ext with
+ (* substitutes [t] in [teff_ext] *)
+ | Bool_type_eff -> Bool_type_eff
+ | Int_type_eff -> Int_type_eff
+ | Real_type_eff -> Real_type_eff
+ | External_type_eff l -> External_type_eff l
+ | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
+ | Array_type_eff(teff_ext,i) ->
+ Array_type_eff(subst_type t teff_ext, i)
+ | Struct_type_eff(l, fl) ->
+ Struct_type_eff(
+ l, List.map (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt))) fl)
+ | Any
+ | Overload -> t
let (type_of_const_eff: const_eff -> type_eff) =
diff --git a/src/evalType.ml b/src/evalType.ml
index 627465a5dae113ceb4c21aa85d725970f1244a9b..666da7c009de42c0021e758734cf8f41d73e569c 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/08/2008 (at 11:23) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 09:19) by Erwan Jahier> *)
open Predef
@@ -27,6 +27,7 @@ let (val_exp_eff : val_exp_eff -> type_eff list) =
try Hashtbl.find val_exp_eff_type_tab vef
with _ -> assert false
+
(******************************************************************************)
let finish_me msg = print_string ("\n\tXXX evalType.ml:"^msg^" -> finish me!\n")
let rec (f : id_solver -> val_exp_eff -> type_eff list) =
@@ -50,9 +51,25 @@ and (eval_by_pos_type :
id_solver -> by_pos_op_eff -> Lxm.t -> val_exp_eff list -> type_eff list) =
fun id_solver posop lxm args ->
match posop with
- | Predef_eff (op,sargs) ->
- PredefEvalType.f op lxm sargs (List.map (f id_solver) args)
-
+ | Predef_eff (op,sargs) -> (
+ let targs = List.map (f id_solver) args in
+ let res = PredefEvalType.f op lxm sargs targs in
+ (* Handling iterator calls: cf comments in LucDump.mli *)
+ (match LicDump.poly_op_find lxm with
+ | Some (LicDump.OpProfile(op_lti, op_lto)) ->
+ (* Retrieve the substitution *)
+ let targs = List.flatten targs in
+ (match UnifyType.f (targs@res) (op_lti@op_lto) with
+ | UnifyType.Unif t ->
+ LicDump.tabulate_poly_op lxm (LicDump.Subst(t))
+ | UnifyType.Equal -> ()
+ | UnifyType.Ko _ -> assert false
+ )
+ | None -> ()
+ | _ -> assert false
+ );
+ res
+ )
| CALL_eff node_exp_eff ->
let lti = List.map (fun v -> v.var_type_eff) node_exp_eff.it.inlist_eff in
let lto = List.map (fun v -> v.var_type_eff) node_exp_eff.it.outlist_eff in
@@ -60,13 +77,13 @@ and (eval_by_pos_type :
let llti = List.length lti and lt_args = List.length t_args in
if llti <> lt_args then
raise (EvalType_error(
- sprintf
- "\n*** arity error: %d argument(s) are expected, whereas %d is/are provided"
- llti lt_args))
+ sprintf
+ "\n*** arity error: %d argument(s) are expected, whereas %d is/are provided"
+ llti lt_args))
else
(match UnifyType.f lti t_args with
| UnifyType.Equal -> lto
- | UnifyType.Unif subst -> List.map (UnifyType.subst_type subst) lto
+ | UnifyType.Unif subst -> List.map (subst_type subst) lto
| UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
)
@@ -86,7 +103,7 @@ and (eval_by_pos_type :
let teff =
match UnifyType.f [teff0] [teff1] with
| UnifyType.Equal -> teff1
- | UnifyType.Unif subst -> UnifyType.subst_type subst teff1
+ | UnifyType.Unif subst -> subst_type subst teff1
| UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
in
[Array_type_eff (teff, size0+size1)]
@@ -97,26 +114,26 @@ and (eval_by_pos_type :
| STRUCT_ACCESS_eff fid -> (
let type_args_eff = List.flatten (List.map (f id_solver) args) in
match type_args_eff with
- | [Struct_type_eff (name, fl)] -> (
- try [fst (List.assoc fid fl)]
- with Not_found ->
- raise (EvalType_error
- (Printf.sprintf "%s is not a field of struct %s"
- (Ident.to_string fid)
- (LicDump.string_of_type_eff(List.hd type_args_eff))))
- )
- | [x] -> type_error [x] "struct type"
- | x -> arity_error x "1"
- )
+ | [Struct_type_eff (name, fl)] -> (
+ try [fst (List.assoc fid fl)]
+ with Not_found ->
+ raise (EvalType_error
+ (Printf.sprintf "%s is not a field of struct %s"
+ (Ident.to_string fid)
+ (LicDump.string_of_type_eff(List.hd type_args_eff))))
+ )
+ | [x] -> type_error [x] "struct type"
+ | x -> arity_error x "1"
+ )
| ARRAY_ACCES_eff (_, teff) -> [teff] (* XXX check args type! *)
| ARRAY_SLICE_eff (sieff,teff) ->
- [Array_type_eff(teff, sieff.se_width)]
+ [Array_type_eff(teff, sieff.se_width)]
| HAT_eff(size,ceff) ->
let teff_list = f id_solver ceff in
List.map (fun teff -> Array_type_eff(teff, size)) teff_list
-
+
| ARRAY_eff ->
(* check that args are of the same type *)
let type_args_eff = (List.map (f id_solver) args) in
@@ -147,7 +164,7 @@ and (eval_by_pos_type :
let msg ="the type of a clock cannot be " ^
(String.concat "," (List.map LicDump.string_of_type_eff teff) )
in
- raise(EvalType_error(msg))
+ raise(EvalType_error(msg))
| _ -> raise(EvalType_error("arity error (2 args expected)"))
)
| ARROW_eff
@@ -181,10 +198,10 @@ and (eval_by_name_type : id_solver -> by_name_op_eff -> Lxm.t ->
- creer une table [liste des noms de champs -> ident de type structure] ?
- rajouter dans la table a sa creation une entree dont le nom
est composé du nom des champs ?
- *)
+ *)
finish_me "anonymous struct not yet supported";
assert false
-(* failwith "Finish me: anonymous struct not yet supported" *)
+ (* failwith "Finish me: anonymous struct not yet supported" *)
| STRUCT_eff (pn,opid) -> [id_solver.id2type opid lxm]
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 1067ff8607b01cf69e23bb40dead991b964f1b0a..132c9beff078b2a8c03f9be15375d8550a15e5ce 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/08/2008 (at 10:25) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 11:43) by Erwan Jahier> *)
open Lxm
@@ -667,6 +667,7 @@ and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
def_eff = node_def_eff ();
has_mem_eff = node_def.it.has_mem;
is_safe_eff = node_def.it.is_safe;
+ lxm = lxm;
}
in
let is_a_predef_node n =
diff --git a/src/licDump.ml b/src/licDump.ml
index ba3b3262324be72fe8106614f7846ad83d039159..22870159b6b51f30b1d27c3a2ada40738bd22b82 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 25/08/2008 (at 18:16) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:19) by Erwan Jahier> *)
open CompiledData
open Printf
@@ -12,6 +12,26 @@ let (long : Ident.long -> string) = Ident.string_of_long
let type_alias_table = Hashtbl.create 0
(******************************************************************************)
+(* exported *)
+type tab_elt =
+ | OpProfile of type_eff list * type_eff list
+ | Subst of type_eff
+
+let (polymorph_op_tab: (Lxm.t, tab_elt) Hashtbl.t) = Hashtbl.create 0
+
+let (tabulate_poly_op : Lxm.t -> tab_elt -> unit) =
+ fun key value -> Hashtbl.replace polymorph_op_tab key value
+
+let (poly_op_mem : Lxm.t -> bool) =
+ fun key -> Hashtbl.mem polymorph_op_tab key
+
+let (poly_op_find : Lxm.t -> tab_elt option) =
+ fun x ->
+ try Some (Hashtbl.find polymorph_op_tab x)
+ with _ -> None
+
+let last_poly_var = ref Int_type_eff
+
(** Un-nesting iterator calls.
The idea is the following: each time a nested iterator call
@@ -32,7 +52,9 @@ let type_alias_table = Hashtbl.create 0
(* This table associates to node its definition plus a flag indicating if that
node has been generated. *)
-let (node_alias_tbl : (string, node_exp_eff * bool) Hashtbl.t) = Hashtbl.create 0
+type node_profile = CompiledData.type_eff list * CompiledData.type_eff list
+let (node_alias_tbl : (string, node_exp_eff * tab_elt option * bool) Hashtbl.t) =
+ Hashtbl.create 0
let alias_fresh_var_cpt = ref 0
let create_alias_name long =
incr alias_fresh_var_cpt;
@@ -92,7 +114,7 @@ and string_def_of_type_eff = function
in
"struct " ^
(List.fold_left (f "; ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
-
+
| Any -> "a"
| Overload -> "o"
@@ -114,12 +136,12 @@ and string_of_type_eff = function
Indeed instead of printing:
- node toto(x: int ^ 4) ...
+ node toto(x: int ^ 4) ...
we want to print something like :
- type int4 = int ^ 4;
- node toto(x: int4) ...
+ type int4 = int ^ 4;
+ node toto(x: int4) ...
That may occur only for array actually.
@@ -153,7 +175,7 @@ and dump_type_alias oc =
p ("\ntype " ^ alias_name ^ " = " ^ (string_def_of_type_eff type_eff)^";")
)
type_alias_table
-
+
(******************************************************************************)
(* exported *)
@@ -161,20 +183,39 @@ and (dump_node_alias : out_channel -> unit) =
fun oc ->
let p = output_string oc in
let finished = ref true in
- let f alias (node, dumped) =
- if not dumped then (
- finished := false;
- p "node ";
- p alias;
- p (profile_of_node_exp_eff node);
- p "let\n ";
- p (Ident.to_string (List.hd node.outlist_eff).var_name_eff);
- p " = ";
- p (string_of_node_key_iter node.node_key_eff);
- p( "("^(Ident.to_string (List.hd node.inlist_eff).var_name_eff)^")");
- p ";\ntel\n";
- Hashtbl.replace node_alias_tbl alias (node,true)
- )
+ let f alias (node, np, dumped) =
+ let _ =
+ match np with
+ | Some(Subst(t)) -> last_poly_var := t
+ | Some(OpProfile(_)) | None -> ()
+ in
+ let get_name_and_type_string var =
+ let t = subst_type !last_poly_var var.var_type_eff in
+ (Ident.to_string var.var_name_eff) ^ ":" ^ (string_of_type_eff t)
+ in
+ let inlist = List.map get_name_and_type_string node.inlist_eff
+ and outlist = List.map get_name_and_type_string node.outlist_eff
+ in
+ let profile = ("("^(String.concat "; " inlist)^") returns ("^
+ (String.concat "; " outlist)^");\n")
+ in
+ if not dumped then (
+ finished := false;
+ p "node ";
+ p alias;
+ (* p (profile_of_node_exp_eff node); *)
+ p profile;
+ p "let\n ";
+ p (Ident.to_string (List.hd node.outlist_eff).var_name_eff);
+ p " = ";
+ p (string_of_node_key_iter node.lxm node.node_key_eff);
+ p "(";
+ p (String.concat ","
+ (List.map (fun v -> Ident.to_string v.var_name_eff) node.inlist_eff));
+ p ")";
+ p ";\ntel\n";
+ Hashtbl.replace node_alias_tbl alias (node, np, true)
+ )
in
p "\n";
Hashtbl.iter f node_alias_tbl;
@@ -194,7 +235,7 @@ and string_of_type_eff_list = function
| l -> String.concat " * " (List.map string_of_type_eff l)
-
+
(* for printing recursive node *)
and string_of_node_key_rec (nkey: node_key) =
match nkey with
@@ -204,35 +245,40 @@ and string_of_node_key_rec (nkey: node_key) =
sprintf "%s_%s" (long ik) (String.concat "_" astrings)
(* for printing iterators *)
-and string_of_node_key_iter (nkey: node_key) =
+and string_of_node_key_iter lxm (nkey: node_key) =
match nkey with
| (ik, []) -> long ik
| (ik, salst) ->
- let astrings = List.map (static_arg2string false) salst in
+ let astrings = List.map (static_arg2string (Some lxm)) salst in
sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)
(* for printing recursive node *)
and static_arg2string_rec (sa : static_arg_eff) =
- match sa with
- | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
- | TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
- | NodeStaticArgEff (id, opeff) ->
- sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)
+ match sa with
+ | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
+ | TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
+ | NodeStaticArgEff (id, opeff) ->
+ sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)
(* for printing iterators *)
-and static_arg2string flag (sa : static_arg_eff) =
- match sa with
- | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
- | TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
- | NodeStaticArgEff (id, opeff) ->
- if
- (snd opeff.node_key_eff) = []
- then
- sprintf "%s" (string_of_node_key_iter opeff.node_key_eff)
- else
- let alias = create_alias_name (fst opeff.node_key_eff) in
- Hashtbl.add node_alias_tbl alias (opeff, false);
- sprintf "%s" alias
+and static_arg2string lxm_opt (sa : static_arg_eff) =
+ match sa with
+ | ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
+ | TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
+ | NodeStaticArgEff (id, opeff) ->
+ if
+ (snd opeff.node_key_eff) = []
+ then
+ sprintf "%s" (string_of_node_key_iter opeff.lxm opeff.node_key_eff)
+ else
+ let np =
+ match lxm_opt with
+ | None -> None
+ | Some lxm -> poly_op_find lxm
+ in
+ let alias = create_alias_name (fst opeff.node_key_eff) in
+ Hashtbl.add node_alias_tbl alias (opeff, np, false);
+ sprintf "%s" alias
and (string_of_var_info_eff: var_info_eff -> string) =
fun x ->
@@ -261,10 +307,10 @@ and string_of_slice_info_eff si_eff =
and (string_of_leff : left_eff -> string) =
function
- | LeftVarEff (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff
- | LeftFieldEff(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
- | LeftArrayEff(leff,i,_) -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
- | LeftSliceEff(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)
+ | LeftVarEff (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff
+ | LeftFieldEff(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
+ | LeftArrayEff(leff,i,_) -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
+ | LeftSliceEff(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)
and (string_of_leff_list : left_eff list -> string) =
fun l ->
@@ -275,50 +321,51 @@ and (string_of_leff_list : left_eff list -> string) =
-and (string_of_by_pos_op_eff : by_pos_op_eff -> val_exp_eff list -> string) =
+and (string_of_by_pos_op_eff: by_pos_op_eff srcflagged -> val_exp_eff list -> string) =
fun posop vel ->
let tuple vel = (String.concat ", " (List.map string_of_val_exp_eff vel)) in
let tuple_par vel = "(" ^ (tuple vel) ^ ")" in
let tuple_square vel =
- "[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
+ "[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
in
+ let lxm = posop.src in
let str =
- match posop,vel with
+ match posop.it,vel with
| Predef_eff (Predef.IF_n,_), [ve1; ve2; ve3] ->
" if " ^ (string_of_val_exp_eff ve1) ^
- " then " ^ (string_of_val_exp_eff ve2) ^
- " else " ^ (string_of_val_exp_eff ve3)
+ " then " ^ (string_of_val_exp_eff ve2) ^
+ " else " ^ (string_of_val_exp_eff ve3)
| Predef_eff(op,sargs), vel ->
- if Predef.is_infix op then (
- match vel with
- | [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^
- " " ^ (string_of_val_exp_eff ve2)
- | _ -> assert false
- )
- else
- ((Predef.op2string op) ^
- (if sargs = [] then
- match op with
- | Predef.ICONST_n _ | Predef.RCONST_n _ | Predef.NOT_n
- | Predef.UMINUS_n | Predef.IUMINUS_n | Predef.RUMINUS_n
- | Predef.FALSE_n | Predef.TRUE_n -> tuple vel
- | _ -> tuple_par vel
- else
- "<<" ^
- (String.concat ", " (List.map (static_arg2string true) sargs))
- ^ ">>" ^ (tuple_par vel)))
-
+ if Predef.is_infix op then (
+ match vel with
+ | [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^
+ " " ^ (string_of_val_exp_eff ve2)
+ | _ -> assert false
+ )
+ else
+ ((Predef.op2string op) ^
+ (if sargs = [] then
+ match op with
+ | Predef.ICONST_n _ | Predef.RCONST_n _ | Predef.NOT_n
+ | Predef.UMINUS_n | Predef.IUMINUS_n | Predef.RUMINUS_n
+ | Predef.FALSE_n | Predef.TRUE_n -> tuple vel
+ | _ -> tuple_par vel
+ else
+ "<<" ^
+ (String.concat ", " (List.map (static_arg2string (Some lxm)) sargs))
+ ^ ">>" ^ (tuple_par vel)))
+
| CALL_eff nee, _ -> (
if nee.it.def_eff = ExternEff then
- ((string_of_node_key_iter nee.it.node_key_eff) ^ (tuple_par vel))
- else
+ ((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
+ else
(* recursive node cannot be extern *)
((string_of_node_key_rec nee.it.node_key_eff) ^ (tuple_par vel))
)
| IDENT_eff idref, _ -> Ident.string_of_idref idref
- | CONST_eff (idref,pn), _ ->
+ | CONST_eff (idref,pn), _ ->
Ident.string_of_idref (
match Ident.pack_of_idref idref with
| Some _ -> idref
@@ -351,9 +398,9 @@ and (string_of_by_pos_op_eff : by_pos_op_eff -> val_exp_eff list -> string) =
| ARRAY_SLICE_eff(_,_), _ -> assert false (* todo *)
| MERGE_eff _, _ -> assert false (* todo *)
-(* | ITERATOR_eff _, _ -> assert false (* todo *) *)
+ (* | ITERATOR_eff _, _ -> assert false (* todo *) *)
-(* Cannot happen *)
+ (* Cannot happen *)
| ARROW_eff, _ -> assert false
| FBY_eff, _ -> assert false
| CONCAT_eff, _ -> assert false
@@ -377,7 +424,7 @@ and (string_of_by_pos_op_eff : by_pos_op_eff -> val_exp_eff list -> string) =
Str.string_match (Str.regexp ")$") str 0 )
||
(* ident or predef constants *)
- (do_not_parenthesize (posop,vel))
+ (do_not_parenthesize (posop.it,vel))
then
str
else
@@ -385,7 +432,7 @@ and (string_of_by_pos_op_eff : by_pos_op_eff -> val_exp_eff list -> string) =
and string_of_val_exp_eff = function
| CallByPosEff (by_pos_op_eff, OperEff vel) ->
- (string_of_by_pos_op_eff by_pos_op_eff.it vel)
+ (string_of_by_pos_op_eff by_pos_op_eff vel)
| CallByNameEff(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
@@ -432,8 +479,8 @@ and string_of_eq_info_eff (leff_list, vee) =
and (string_of_assert : val_exp_eff srcflagged -> string ) =
fun eq_eff ->
- wrap_long_line (
- "assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")
+ wrap_long_line (
+ "assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")
and (string_of_eq : eq_info_eff srcflagged -> string) =
fun eq_eff ->
@@ -450,8 +497,8 @@ and wrap_long_profile str =
and (profile_of_node_exp_eff: node_exp_eff -> 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.inlist_eff "; ") ^ ") returns (" ^
+ (string_of_type_decl_list neff.outlist_eff "; ") ^ ");\n")
and (string_of_node_def : node_def_eff -> string list) =
function
@@ -462,7 +509,7 @@ and (string_of_node_def : node_def_eff -> string list) =
(List.map string_of_assert node_body_eff.asserts_eff)
(List.map string_of_eq node_body_eff.eqs_eff)
-
+
(* exported *)
and (type_decl: Ident.long -> type_eff -> string) =
@@ -487,7 +534,7 @@ and (const_decl: Ident.long -> const_eff -> string) =
| Int_const_eff _
| Real_const_eff _ -> str^" = " ^ (string_of_const_eff ceff)^ ";\n"
)
-
+
(* exported *)
and (node_of_node_exp_eff: node_exp_eff -> string) =
fun neff ->
@@ -531,8 +578,8 @@ and string_of_clock (ck : clock_eff) =
| BaseEff -> ""
| On(_,BaseEff) -> ""
| On(v,On(id,_)) ->" when " ^ (Ident.to_string id)
-(* | On(v,ClockVar i) -> " when _clock_var_"^ (string_of_int i) *)
-(* | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)
+ (* | On(v,ClockVar i) -> " when _clock_var_"^ (string_of_int i) *)
+ (* | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)
| _ -> assert false
@@ -542,21 +589,21 @@ and string_of_clock_list cl =
(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
-let node_error_string nkey = (
- Printf.sprintf "While checking %s" (string_of_node_key_iter nkey)
+let node_error_string lxm nkey = (
+ Printf.sprintf "While checking %s" (string_of_node_key_iter lxm nkey)
)
(*---------------------------------------------------------------------
Message d'erreur (associé à un lexeme) sur stderr
----------------------------------------------------------------------*)
let print_compile_node_error nkey lxm msg = (
- Printf.eprintf "%s\n" (node_error_string nkey);
+ Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_compile_error lxm msg ;
flush stderr
)
-let print_global_node_error nkey msg = (
- Printf.eprintf "%s\n" (node_error_string nkey);
+let print_global_node_error lxm nkey msg = (
+ Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_global_error msg ;
flush stderr
)
diff --git a/src/licDump.mli b/src/licDump.mli
index e1a50f894b0b2cba403601b3e4336834091c7987..c93af2e8c49d38994b8452372ac8291cbc25f9a9 100644
--- a/src/licDump.mli
+++ b/src/licDump.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 25/08/2008 (at 18:04) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 16:09) by Erwan Jahier> *)
open CompiledData
@@ -25,7 +25,43 @@ val dump_type_alias : out_channel -> unit
val dump_node_alias : out_channel -> unit
-(* used for error msgs *)
+(* Remember the type of iterator calls.
+
+ The type of the expression "map<<+,3>>" depends on its
+ context. And when translating expressions like
+ "map<<map<<+,3>>,42>>", we create an alias node for
+ "map<<+,3>>". But this node have an overloaded type (the same
+ problem occur when iterating of polymorphic op).
+
+ One difficulty is that we can know the type of this call only
+ at the top level iterator.
+
+ Therefore we procees in two step :
+ (1) each time we see an iterator call, we tabulate its profile
+ (cf OpProfile constructor below), that migth contain some
+ type variables (well, at most one for the time being).
+ (2) When we type check the expression, we know the substition
+ for that type var. So we tabulate it (cf Subst constructor below).
+
+ The problem is that the inner iterator calls are never typed check !
+ (well, more precisely, EvalType.f is never called for them, besause
+ they have been transformed into a node_exp_eff that is polymorphic).
+ The (diry) trick I use is to store the substitution in a internal
+ reference, that is uses as soon a I have to deal with a type var.
+ It works because the outter iter call is treated before the inner
+ ones, and because no other call to dump_node_alias is
+ intertwinned...
+*)
+type tab_elt =
+ | OpProfile of type_eff list * type_eff list
+ | Subst of type_eff
+val tabulate_poly_op : Lxm.t -> tab_elt -> unit
+val poly_op_mem : Lxm.t -> bool
+val poly_op_find : Lxm.t -> tab_elt option
+
+
+(* used for error msgs *)
val string_of_clock2 : clock_eff -> string
val string_of_val_exp_eff : val_exp_eff -> string
+
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index fc1b81574f228043b54815ea34b52e90bf4475ed..addde1dad5dc43b675df18bf9b9e29343f47dc1e 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/08/2008 (at 15:57) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 15:55) by Erwan Jahier> *)
open Predef
open SyntaxTreeCore
@@ -83,7 +83,7 @@ let (get_node_and_constant:static_arg_eff list -> node_exp_eff * int)=
| [NodeStaticArgEff(_,n);ConstStaticArgEff(_,Int_const_eff c)] -> n,c
| _ -> assert false
-
+
let map_profile =
(* Given
- a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
@@ -95,7 +95,12 @@ let map_profile =
let (n,c) = get_node_and_constant sargs in
let lti = type_to_array_type n.inlist_eff c in
let lto = type_to_array_type n.outlist_eff c in
- (lti, lto)
+ let res = (lti, lto) in
+ if not(LicDump.poly_op_mem lxm) then (
+ LicDump.tabulate_poly_op lxm
+ (LicDump.OpProfile (snd (List.split lti), snd(List.split lto)))
+ );
+ res
let get_id_type vi = vi.var_name_eff, vi.var_type_eff
@@ -116,14 +121,24 @@ let (fillred_profile : Lxm.t -> CompiledData.static_arg_eff list ->
let lto = (get_id_type (List.hd n.outlist_eff))::
type_to_array_type (List.tl n.outlist_eff) 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)
+ | 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
+ if not(LicDump.poly_op_mem lxm) then (
+(* print_string ("*** Tabulating " ^ lxm._str ^":"^(string_of_int lxm._line) *)
+(* ^"."^(string_of_int lxm._cstart) ^ "\n"); *)
+(* flush stdout; *)
+ LicDump.tabulate_poly_op lxm
+ (LicDump.OpProfile (snd (List.split lti), snd(List.split lto)))
+ );
+ res
(* let fill_profile = fillred_profile *)
(* Given
@@ -161,28 +176,32 @@ let boolred_profile =
type node_profile = (Ident.t * type_eff) list * (Ident.t * type_eff) list
+
+
let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
- fun op lxm sargs -> match op with
- | TRUE_n | FALSE_n -> b_profile
- | ICONST_n id -> i_profile
- | RCONST_n id -> r_profile
- | NOT_n -> bb_profile
- | REAL2INT_n -> ri_profile
- | INT2REAL_n -> ir_profile
- | IF_n -> baaa_profile
- | UMINUS_n -> oo_profile
- | IUMINUS_n -> ii_profile
- | RUMINUS_n -> rr_profile
- | IMPL_n | AND_n | OR_n | XOR_n -> bbb_profile
- | NEQ_n | EQ_n | LT_n | LTE_n | GT_n | GTE_n -> aab_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
-
- | NOR_n | DIESE_n -> assert false
+ fun op lxm sargs ->
+ let res =
+ match op with
+ | TRUE_n | FALSE_n -> b_profile
+ | ICONST_n id -> i_profile
+ | RCONST_n id -> r_profile
+ | NOT_n -> bb_profile
+ | REAL2INT_n -> ri_profile
+ | INT2REAL_n -> ir_profile
+ | IF_n -> baaa_profile
+ | UMINUS_n -> oo_profile
+ | IUMINUS_n -> ii_profile
+ | RUMINUS_n -> rr_profile
+ | IMPL_n | AND_n | OR_n | XOR_n -> bbb_profile
+ | NEQ_n | EQ_n | LT_n | LTE_n | GT_n | GTE_n -> aab_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
+
+ | NOR_n | DIESE_n -> assert false
(* XXX The current representation of node_profile prevent us
from being able to represent "bool list" (i.e., operator
of variable arity). I could extend the type node_profile,
@@ -191,7 +210,8 @@ let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
this data type, I don'ty know how I could generate an
alias node for them anyway...
*)
-
+ in
+ res
(* exported *)
let (make_node_exp_eff :
bool option -> op -> Lxm.t -> static_arg_eff list -> node_exp_eff) =
@@ -222,6 +242,7 @@ let (make_node_exp_eff :
def_eff = ExternEff;
has_mem_eff = (match has_mem with Some b -> b | None -> true);
is_safe_eff = true;
+ lxm = lxm;
}
(* exported *)
@@ -253,24 +274,6 @@ let (f : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
let node_eff = make_node_exp_eff (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 rec (subst_type : type_eff -> type_eff -> type_eff) =
- fun t teff -> match teff with
- (* substitutes [t] in [teff] *)
- | Bool_type_eff -> Bool_type_eff
- | Int_type_eff -> Int_type_eff
- | Real_type_eff -> Real_type_eff
- | External_type_eff l -> External_type_eff l
- | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
- | Array_type_eff(teff,i) -> Array_type_eff(subst_type t teff, i)
- | Struct_type_eff(l, fl) ->
- Struct_type_eff(
- l,
- List.map
- (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt)))
- fl)
- | Any
- | Overload -> t
- in
let l = List.flatten ll in
if (List.length l <> List.length lti) then
arity_error [l] (string_of_int (List.length lti))
diff --git a/src/predefEvalType.mli b/src/predefEvalType.mli
index dcef6ea70779effb5d07a000bca250c34d40831d..d5e0094205dccc201fd675363fee4321a99551e7 100644
--- a/src/predefEvalType.mli
+++ b/src/predefEvalType.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/08/2008 (at 15:57) by Erwan Jahier> *)
+(** Time-stamp: <modified the 26/08/2008 (at 14:49) by Erwan Jahier> *)
open CompiledData
diff --git a/src/test/should_work/call/bad_call03.lus b/src/test/should_work/call/bad_call03.lus
index c8a5e8a9728d76f684dfc04dfe00bace34bd492c..69dc316c5cb8e4ef121fb95049208435ec8e44b5 100644
--- a/src/test/should_work/call/bad_call03.lus
+++ b/src/test/should_work/call/bad_call03.lus
@@ -1,4 +1,6 @@
-- Well, this one is acceptable after all...
+-- Well, not as long as there is no polymorphic syntax in lic
+
node toto = map<<+, 3>>;
diff --git a/src/test/should_work/demo/mapdeRed.lus b/src/test/should_work/demo/mapdeRed.lus
index b83202aa498f2124b3c71f13f52913ec3853e8bc..c5472cfa387aa4c33f1c493eda05d3796c75c9dc 100644
--- a/src/test/should_work/demo/mapdeRed.lus
+++ b/src/test/should_work/demo/mapdeRed.lus
@@ -16,4 +16,4 @@ node incr(i: int) returns (accu, s: int);
let
accu = i + 1;
s = i;
-tel
\ No newline at end of file
+tel
diff --git a/src/test/test.res.exp b/src/test/test.res.exp
index 3011281ab194d5dfb2febca02c2c039ae397c1e3..b08a5d0b6dbb376f287aca0291e1a60f609f5125 100644
--- a/src/test/test.res.exp
+++ b/src/test/test.res.exp
@@ -11264,9 +11264,9 @@ tel
-- automatically defined aliases:
type A_A_int_2_3 = A_int_2^3;
type A_int_2 = int^2;
-node _node_alias_2_Lustre::map(i1:A_o_2; i2:A_o_2) returns (o:A_o_2);
+node _node_alias_2_Lustre::map(i1:A_int_2; i2:A_int_2) returns (o:A_int_2);
let
- o = Lustre::map<<Lustre::plus, 2>>(i1);
+ o = Lustre::map<<Lustre::plus, 2>>(i1,i2);
tel
node _node_alias_1_Lustre::fill(i:int) returns (accu:int; s:A_int_2);
let
@@ -11411,7 +11411,7 @@ type A_A_int_5_3 = A_int_5^3;
type A_int_5 = int^5;
node _node_alias_1_Lustre::red(init:int; a:A_int_5) returns (b:int);
let
- b = Lustre::red<<rediter::max, 5>>(init);
+ b = Lustre::red<<rediter::max, 5>>(init,a);
tel
@@ -11434,9 +11434,9 @@ tel
-- automatically defined aliases:
type A_A_int_5_3 = A_int_5^3;
type A_int_5 = int^5;
-node _node_alias_1_Lustre::red(i1:o; i2:A_o_5) returns (o:o);
+node _node_alias_1_Lustre::red(i1:int; i2:A_int_5) returns (o:int);
let
- o = Lustre::red<<Lustre::plus, 5>>(i1);
+ o = Lustre::red<<Lustre::plus, 5>>(i1,i2);
tel
@@ -15984,11 +15984,11 @@ type A_A_A_bool_4_3_2 = A_A_bool_4_3^2;
type A_int_4 = int^4;
node _node_alias_4_Lustre::fillred(ci:bool; x:A_A_bool_4_3; y:A_A_bool_4_3) returns (co:bool; s:A_A_bool_4_3);
let
- co = Lustre::fillred<<_node_alias_6_Lustre::fillred, 3>>(ci);
+ co = Lustre::fillred<<_node_alias_6_Lustre::fillred, 3>>(ci,x,y);
tel
node _node_alias_5_Lustre::red(i1:bool; i2:A_A_bool_4_3) returns (o:bool);
let
- o = Lustre::red<<_node_alias_7_Lustre::red, 3>>(i1);
+ o = Lustre::red<<_node_alias_7_Lustre::red, 3>>(i1,i2);
tel
node _node_alias_3_Lustre::fill(accin:int) returns (accout:int; val:A_A_int_4_3);
let
@@ -15996,11 +15996,11 @@ let
tel
node _node_alias_2_Lustre::red(i1:bool; i2:A_A_bool_4_3) returns (o:bool);
let
- o = Lustre::red<<_node_alias_9_Lustre::red, 3>>(i1);
+ o = Lustre::red<<_node_alias_9_Lustre::red, 3>>(i1,i2);
tel
-node _node_alias_1_Lustre::red(i1:o; i2:A_A_o_4_3) returns (o:o);
+node _node_alias_1_Lustre::red(i1:int; i2:A_A_int_4_3) returns (o:int);
let
- o = Lustre::red<<_node_alias_10_Lustre::red, 3>>(i1);
+ o = Lustre::red<<_node_alias_10_Lustre::red, 3>>(i1,i2);
tel
node _node_alias_8_Lustre::fill(accin:int) returns (accout:int; val:A_int_4);
@@ -16009,19 +16009,19 @@ let
tel
node _node_alias_7_Lustre::red(i1:bool; i2:A_bool_4) returns (o:bool);
let
- o = Lustre::red<<Lustre::xor, 4>>(i1);
+ o = Lustre::red<<Lustre::xor, 4>>(i1,i2);
tel
node _node_alias_6_Lustre::fillred(ci:bool; x:A_bool_4; y:A_bool_4) returns (co:bool; s:A_bool_4);
let
- co = Lustre::fillred<<arrays::full_adder, 4>>(ci);
+ co = Lustre::fillred<<arrays::full_adder, 4>>(ci,x,y);
tel
-node _node_alias_10_Lustre::red(i1:o; i2:A_o_4) returns (o:o);
+node _node_alias_10_Lustre::red(i1:int; i2:A_int_4) returns (o:int);
let
- o = Lustre::red<<Lustre::plus, 4>>(i1);
+ o = Lustre::red<<Lustre::plus, 4>>(i1,i2);
tel
node _node_alias_9_Lustre::red(i1:bool; i2:A_bool_4) returns (o:bool);
let
- o = Lustre::red<<Lustre::or, 4>>(i1);
+ o = Lustre::red<<Lustre::or, 4>>(i1,i2);
tel
@@ -16340,9 +16340,9 @@ tel
type A_int_2 = int^2;
type A_A_int_3_2 = A_int_3^2;
type A_int_3 = int^3;
-node _node_alias_2_Lustre::red(i1:o; i2:A_o_3) returns (o:o);
+node _node_alias_2_Lustre::red(i1:int; i2:A_int_3) returns (o:int);
let
- o = Lustre::red<<Lustre::plus, 3>>(i1);
+ o = Lustre::red<<Lustre::plus, 3>>(i1,i2);
tel
node _node_alias_1_Lustre::fill(accu_in:A_int_2) returns (accu_out:A_int_2; elt:A_int_3);
let
@@ -16368,9 +16368,9 @@ tel
-- automatically defined aliases:
type A_A_int_2_2 = A_int_2^2;
type A_int_2 = int^2;
-node _node_alias_1_Lustre::red(i1:o; i2:A_o_2) returns (o:o);
+node _node_alias_1_Lustre::red(i1:int; i2:A_int_2) returns (o:int);
let
- o = Lustre::red<<Lustre::plus, 2>>(i1);
+ o = Lustre::red<<Lustre::plus, 2>>(i1,i2);
tel
@@ -16419,11 +16419,11 @@ let
tel
node _node_alias_3_Lustre::red(i1:bool; i2:A_bool_3) returns (o:bool);
let
- o = Lustre::red<<Lustre::xor, 3>>(i1);
+ o = Lustre::red<<Lustre::xor, 3>>(i1,i2);
tel
-node _node_alias_1_Lustre::map(c:A_bool_3; b1:A_a_3; b2:A_a_3) returns (o:A_a_3);
+node _node_alias_1_Lustre::map(c:A_bool_3; b1:A_bool_3; b2:A_bool_3) returns (o:A_bool_3);
let
- o = Lustre::map<<Lustre::if, 3>>(c);
+ o = Lustre::map<<Lustre::if, 3>>(c,b1,b2);
tel
@@ -16998,23 +16998,23 @@ let
tel
node _node_alias_3_Lustre::red(init:int; b:A_bool_2) returns (res:int);
let
- res = Lustre::red<<predefOp::incr, 2>>(init);
+ res = Lustre::red<<predefOp::incr, 2>>(init,b);
tel
-node _node_alias_4_Lustre::map(i1:A_o_2; i2:A_o_2) returns (o:A_o_2);
+node _node_alias_4_Lustre::map(i1:A_int_2; i2:A_int_2) returns (o:A_int_2);
let
- o = Lustre::map<<Lustre::div, 2>>(i1);
+ o = Lustre::map<<Lustre::div, 2>>(i1,i2);
tel
-node _node_alias_5_Lustre::map(i1:A_a_2; i2:A_a_2) returns (o:A_bool_2);
+node _node_alias_5_Lustre::map(i1:A_int_2; i2:A_int_2) returns (o:A_bool_2);
let
- o = Lustre::map<<Lustre::gte, 2>>(i1);
+ o = Lustre::map<<Lustre::gte, 2>>(i1,i2);
tel
node _node_alias_2_Lustre::map(i1:A_bool_2; i2:A_bool_2) returns (o:A_bool_2);
let
- o = Lustre::map<<Lustre::impl, 2>>(i1);
+ o = Lustre::map<<Lustre::impl, 2>>(i1,i2);
tel
-node _node_alias_6_Lustre::red(i1:o; i2:A_o_2) returns (o:o);
+node _node_alias_6_Lustre::red(i1:int; i2:A_int_2) returns (o:int);
let
- o = Lustre::red<<Lustre::plus, 2>>(i1);
+ o = Lustre::red<<Lustre::plus, 2>>(i1,i2);
tel
diff --git a/src/unifyType.ml b/src/unifyType.ml
index 9fac3b4e5b59c92359b1573e2eec4c3ed5d6f760..725e5b79ee5cf96f8469648a291c2feede2f3937 100644
--- a/src/unifyType.ml
+++ b/src/unifyType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/07/2008 (at 10:57) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 15:37) by Erwan Jahier> *)
open CompiledData
@@ -91,24 +91,6 @@ let (f : type_eff list -> type_eff list -> t) = fun l1 l2 ->
List.fold_left2 unify_do_acc Equal l1 l2
-(* exported *)
-let rec (subst_type : type_eff -> type_eff -> type_eff) =
- fun t teff_ext -> match teff_ext with
- (* substitutes [t] in [teff_ext] *)
- | Bool_type_eff -> Bool_type_eff
- | Int_type_eff -> Int_type_eff
- | Real_type_eff -> Real_type_eff
- | External_type_eff l -> External_type_eff l
- | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
- | Array_type_eff(teff_ext,i) ->
- Array_type_eff(subst_type t teff_ext, i)
- | Struct_type_eff(l, fl) ->
- Struct_type_eff(
- l, List.map (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt))) fl)
- | Any
- | Overload -> t
-
-
(************************************************************************************)
(* Some unit tests *)
let i = Int_type_eff
diff --git a/src/unifyType.mli b/src/unifyType.mli
index 7cd2e5c3ca04b88841e4e7fc8111faf9e82a8e4d..6b9d7ba9e49e11f386db0161fb2fd19b058a7d17 100644
--- a/src/unifyType.mli
+++ b/src/unifyType.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 09/06/2008 (at 10:06) by Erwan Jahier> *)
+(** Time-stamp: <modified the 27/08/2008 (at 15:48) by Erwan Jahier> *)
(** This unify function is quite specific. It can only unify 2 lists
of types with at most one type variable (Any or Overload).
@@ -20,10 +20,6 @@ type t =
val f : CompiledData.type_eff list -> CompiledData.type_eff list -> t
-(** [subst_type t1 t2 substitutes [t1] in [t2] *)
-val subst_type :
- CompiledData.type_eff -> CompiledData.type_eff -> CompiledData.type_eff
-
(**/**)
val unit_test : unit -> unit