diff --git a/Makefile b/Makefile
index 69e40a46798da1ff0fc27abfbcd058b4f1bca5d0..7838fcc4d790820626abfc02853f5988572decec 100644
--- a/Makefile
+++ b/Makefile
@@ -62,7 +62,6 @@ SOURCES = \
$(OBJDIR)/eff.ml \
$(OBJDIR)/name.mli \
$(OBJDIR)/name.ml \
- $(OBJDIR)/polymorphism.ml \
$(OBJDIR)/licDump.ml \
$(OBJDIR)/licPrg.mli \
$(OBJDIR)/licPrg.ml \
diff --git a/overload.lus b/overload.lus
index 38488e02b51f96933066d857471a3c3534e2f5a9..e06efc226493c7c407edab0bce7a7e4032af9df7 100644
--- a/overload.lus
+++ b/overload.lus
@@ -7,6 +7,3 @@ let o = overplus(x,y); tel
node do_real(x,y: real^4) returns (o: real^4);
let o = overplus(x,y); tel
-
-node do_bool(x,y: bool^4) returns (o: bool^4);
-let o = overplus(x,y); tel
diff --git a/src/getEff.ml b/src/getEff.ml
index 81df594672210d96590227828bc5b7bd60f4cde5..9370f9fe3d2bfb4454b508ff8357c36f1ea3658e 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -104,6 +104,7 @@ and (clock_check_equation:Eff.id_solver -> Lxm.t -> UnifyClock.subst ->
(******************************************************************************)
+(* OBSOLETE
let (dump_polymorphic_nodes : Eff.type_ -> unit) =
fun t ->
let node_stack = Polymorphism.unstack_polymorphic_nodes t in
@@ -118,7 +119,7 @@ let (dump_polymorphic_nodes : Eff.type_ -> unit) =
nnodes;
)
node_stack
-
+*)
(******************************************************************************)
let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
@@ -496,7 +497,10 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
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 ... *)
+ 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
| Map ->
PredefEvalType.map_profile lxm sargs_eff
@@ -508,8 +512,14 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
PredefEvalType.condact_profile lxm sargs_eff
| _ -> raise Not_found
in
+
+ (* Filtre uniquement la liste des types d'entrées attendus *)
let type_l_exp = snd (List.split (fst iter_profile)) in
+ (* Correction éventuelle des static args par le
+ "any(num)" nécéssaire à l'unification des
+ types d'entrée (AFAIRE : moche moche ...
+ *)
let sargs_eff =
if List.length type_l <> List.length type_l_exp then
let str = Printf.sprintf
@@ -524,9 +534,9 @@ and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
| UnifyType.Equal -> sargs_eff
| UnifyType.Unif typ ->
(* The iterated nodes was polymorphic, but we know here
- that the type variable was [typ].
+ that the MISSING type variable was [typ].
*)
- dump_polymorphic_nodes typ;
+ (* dump_polymorphic_nodes typ; *)
List.map (instanciate_type typ) sargs_eff
| UnifyType.Ko str -> raise (Compile_error(lxm, str))
in let mk_by_pos_op by_pos_op_eff =
diff --git a/src/getEff.mli b/src/getEff.mli
index ec256f11bdc1c137e133c0d1606135e74c144901..0af354ff53461316e7913e133a0219686f787275 100644
--- a/src/getEff.mli
+++ b/src/getEff.mli
@@ -41,4 +41,6 @@ val translate_predef_static_args:
(** Instanciate the frozen polymorphic nodes using the type in
argument, and (Lic)dump them (cf Polymorphism). *)
+(* OBSOLETE
val dump_polymorphic_nodes : Eff.type_ -> unit
+*)
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 034d22707de1128e9c771bd3eb68b068a88b89b3..37832db20471c35e347fdd9c473f7f2fbea29e25 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -647,6 +647,7 @@ and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
let topt = UnifyType.profile_is_compatible nk
node_def.src (iptypes,ibtypes) (optypes,obtypes)
in
+(* OBSOLETE
let _ =
(* the type profile seems ok, but it may need to unfreeze some
polymorphic nodes *)
@@ -654,6 +655,7 @@ and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
| None -> ()
| Some t -> GetEff.dump_polymorphic_nodes t
in
+*)
if
prov_node_exp_eff.node_key_eff <> body_node_exp_eff.node_key_eff
then
@@ -1059,12 +1061,14 @@ and node_check_do
(match i_unif_res with
| UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
| UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ | UnifyType.Unif t -> ()
+ (* GetEff.dump_polymorphic_nodes t *)
);
(match o_unif_res with
| UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
| UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
+ | UnifyType.Unif t -> ()
+ (* GetEff.dump_polymorphic_nodes t *)
);
(* ok, there are compatible. We use the declared profile. *)
(il_decl, ol_decl)
diff --git a/src/lazyCompiler.save.ml b/src/lazyCompiler.save.ml
deleted file mode 100644
index 69b902fef7f8acb97a742496f9280850a16e4517..0000000000000000000000000000000000000000
--- a/src/lazyCompiler.save.ml
+++ /dev/null
@@ -1,1434 +0,0 @@
-(** Time-stamp: <modified the 01/06/2011 (at 13:40) by Erwan Jahier> *)
-
-
-open Lxm
-open Errors
-open SyntaxTree
-open SyntaxTreeCore
-open Eff
-
-let finish_me msg = print_string ("\n\tXXX LazyCompiler:"^msg^" -> finish me!\n")
-
-(******************************************************************************)
-(** Returns the ident on which the recursion was detected, plus an execution
- stack description.
-*)
-exception Recursion_error of (Ident.long as 'id) * (string list as 'stack)
-
-exception BadCheckRef_error
-
-let recursion_error (lxm : Lxm.t) (stack : string list) =
- let rec string_of_stack = function
- | [] -> "nostack"
- | s::[] -> s
- | s::l -> s^"\n > "^(string_of_stack l)
- in
- raise ( Compile_error
- (lxm, "Recursion loop detected: \n*** " ^(string_of_stack stack)
- ))
-
-
-(******************************************************************************)
-(* Structure principale *)
-type t = {
- src_tab : SyntaxTab.t;
- (* table des defs *)
- types : (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t;
- consts : (Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t;
- nodes : (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t;
- (* table des prov *)
- prov_types : (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t;
- prov_consts : (Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t;
- prov_nodes : (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t
-}
-
-(******************************************************************************)
-(* exported *)
-
-let (create : SyntaxTab.t -> t) =
- fun tbl ->
- let nodes_tbl = Hashtbl.create 0 in
- let prov_nodes_tbl = Hashtbl.create 0 in
- 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_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)
- )
- Predef.iterable_op;
- {
- src_tab = tbl;
- types = Hashtbl.create 0;
- consts = Hashtbl.create 0;
- nodes = nodes_tbl;
- prov_types = Hashtbl.create 0;
- prov_consts = Hashtbl.create 0;
- prov_nodes = prov_nodes_tbl;
- }
-
-(******************************************************************************)
-
-(** Type checking + constant checking/evaluation
-
- This is performed (lazily) by 10 mutually recursive functions:
-
- checking types
- --------------
- (1) [type_check env type_name lxm]: type check the type id [type_name]
- (2) [type_check_do]: untabulated version of [type_check] (do the real work).
-
- (3) [type_check_interface]: ditto, but for the interface part
- (4) [type_check_interface_do]: untabulated version (do the real work)
-
- (5) [solve_type_idref] solves constant reference (w.r.t. short/long ident)
-
- checking constants
- ------------------
- (6) [const_check env const_name lxm]: eval/check the constant [const_name]
- (7) [const_check_do] : untabulated version (do the real work)
-
- (8) [const_check_interface]: ditto, but for the interface part
- (9) [const_check_interface_do]: untabulated version (do the real work)
-
- (10) [solve_const_idref] solves constant reference (w.r.t. short/long ident)
-
- checking nodes
- --------------
-
- (11) [node_check env node_name lxm]: check the node [node_name]
- checking a node means checking its interface and checking it equations/asserts.
- checking an equation means checking that the type and clock of the
- left part is the same as the ones of the rigth part.
-
-
- (12) [node_check_do] : untabulated version (do the real work)
-
- (13) [node_check_interface]: ditto, but for the interface part
- (14) [node_check_interface_do]: untabulated version (do the real work)
-
- (15) [solve_node_idref] solves constant reference (w.r.t. short/long ident)
-
- XXX checking clocks
- -------------------
- Ditto, but todo!
-
-
- nb: for x in {type, const, node, clock}, there are several functions
- that returns [x_eff]:
- - [x_check]
- o tabulates its result
- o takes an x_key and returns an [x_eff]
- o lookups its (syntaxic) definition (x_info) via the symbolTab.t
- o calls [GetEff.X] to translate its sub-terms
-
- - [GetEff.X]
- o takes a [x_exp] (i.e., an expression) and returns an [x_eff]
- o compute the effective static args (for nodes)
- o calls [solve_x_idref] (via [id_solver]) to translate its sub-terms
-
-
- - [solve_x_idref]
- o takes an idref (plus a «Eff.static_arg list» for x=node!)
- o perform name resolution
- o calls [x_check] (loop!)
-
-
- nb2: the top-level call is [node_check], on a node that necessarily contains
- no static parameters.
-
-
-*)
-
-(* Before starting, let's define a few utilitary functions. *)
-
-(** Intermediary results are put into a table. This tabulation handling
- is common to type and constant checking, and is performed by the
- 2 following functions.
-
- Since [x] is meant to stand for [type], [const], or [node], those 2
- functions will lead to the definition of 6 functions:
- [type_check], [const_check], [node_check],
- [type_check_interface], [const_check_interface], [node_check_interface].
-*)
-let x_check
- tab find_x x_check_do lookup_x_eff pack_of_x_key name_of_x_key this x_key lxm =
- try lookup_x_eff tab x_key lxm
- with Not_found ->
- Hashtbl.add tab x_key Eff.Checking;
- let (x_pack,xn) = (pack_of_x_key x_key, name_of_x_key x_key) in
- let x_pack_symbols = SyntaxTab.pack_body_env this.src_tab x_pack in
- let x_def = match find_x x_pack_symbols xn lxm with
- | SymbolTab.Local x_def -> x_def
- | SymbolTab.Imported (lid,_) ->
- print_string ("*** " ^ (Ident.string_of_long lid) ^ "???\n" ^
- (Lxm.details lxm));
- assert false (* should not occur *)
- in
- let res = x_check_do this x_key lxm x_pack_symbols false x_pack x_def in
- Hashtbl.replace tab x_key (Eff.Checked res);
- res
-
-let x_check_interface
- tab find_x x_check x_check_interface_do lookup_x_eff
- pack_of_x_key name_of_x_key this x_key lxm =
- try lookup_x_eff tab x_key lxm
- with Not_found ->
- Hashtbl.add tab x_key Eff.Checking;
- let (xp,xn) = (pack_of_x_key x_key, name_of_x_key x_key) in
- let xp_prov_symbols_opt = SyntaxTab.pack_prov_env this.src_tab xp lxm in
- let res = (* [xp] migth have no provided symbol table *)
- match xp_prov_symbols_opt with
- | None ->
- (* if [xp] have no provided symbol table, the whole package is exported. *)
- x_check this x_key lxm
- | Some xp_prov_symbols ->
- let x_def = match find_x xp_prov_symbols xn lxm with
- | SymbolTab.Local x -> x
- | SymbolTab.Imported _ -> assert false (* should not occur *)
- in
- x_check_interface_do this x_key lxm xp_prov_symbols xp x_def
- in
- Hashtbl.replace tab x_key (Eff.Checked res);
- res
-
-(* Returns the tabulated [type] or [const], if it has already been computed;
- otherwise, raise [Not_found] otherwise. *)
-let lookup_x_eff x_label id_of_x_key x_tab x_key lxm =
- match Hashtbl.find x_tab x_key with
- | Eff.Checked res -> res
- | Eff.Checking ->
- raise (Recursion_error (id_of_x_key x_key, [x_label^(Lxm.details lxm)]))
- | Eff.Incorrect -> raise (BadCheckRef_error)
-
-let (lookup_type_eff: (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t ->
- Ident.long -> Lxm.t -> Eff.type_) =
- lookup_x_eff "type ref " (fun k -> k)
-
-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 node_exp = lookup_x_eff "node ref " (fun k -> fst k) tbl key lxm in
- Verbose.exe ~level:3
- (fun () ->
- Printf.printf "\n*** %s Founded! \n" (LicDump.string_of_node_key_iter key);
- flush stdout
- );
- 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 ~level:3
- ( fun () ->
- Printf.printf "\n*** Don't find %s in "
- (LicDump.string_of_node_key_iter key);
- Hashtbl.iter (fun nk _ ->
- Printf.printf "%s, " (LicDump.string_of_node_key_iter nk);
- ) tbl;
- flush stdout
- );
- 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.
-
- The [provide_flag] indicates whether that function was called
- from a « provide » part or not.
-*)
-let solve_x_idref
- x_check_interface x_check find_x x_label to_x_key this symbols
- provide_flag currpack idr sargs lxm =
- let s = Ident.name_of_idref idr in
- match Ident.pack_of_idref idr with
- | Some p ->
- if p = currpack
- then x_check this (to_x_key currpack s) lxm
- else x_check_interface this (to_x_key p s) lxm
- | None ->
- (* no pack name: it must be in the symbols table *)
- try
- match (find_x symbols s lxm) with
- | SymbolTab.Local x_info ->
- if provide_flag
- then x_check_interface this (to_x_key currpack s) lxm
- else x_check this (to_x_key currpack s) lxm
-
- | SymbolTab.Imported(fid,params) ->
- let (pi,si) = (Ident.pack_of_long fid, Ident.of_long fid) in
- assert(params=[]); (* todo *)
- x_check_interface this (to_x_key pi si) lxm
-
- with Not_found ->
- (raise (Compile_error(lxm,"unbounded " ^ x_label ^ " ident")))
-
-
-
-
-(******************************************************************************)
-
-let find_var_info lxm vars id =
- try Hashtbl.find vars.vartable id
- with Not_found ->
- raise (Compile_error (lxm,"\n*** Unknown ident: " ^ (Ident.to_string id)))
-
-
-
-
-(* And now we can start the big mutually recursive definition... *)
-
-(** Tabulated version of [type_check_do]. *)
-let rec (type_check : t -> Ident.long -> Lxm.t -> Eff.type_) =
- fun this ->
- x_check this.types SymbolTab.find_type type_check_do lookup_type_eff
- Ident.pack_of_long Ident.of_long this
-
-(** Tabulated version of [const_check_do]. *)
-and (const_check : t -> Ident.long -> Lxm.t -> Eff.const) =
- fun this ->
- x_check this.consts SymbolTab.find_const const_check_do lookup_const_eff
- Ident.pack_of_long Ident.of_long this
-
-(** Tabulated version of [type_check_interface_do]. *)
-and (type_check_interface: t -> Ident.long -> Lxm.t -> Eff.type_) =
- fun this ->
- x_check_interface
- this.prov_types SymbolTab.find_type type_check type_check_interface_do
- lookup_type_eff Ident.pack_of_long Ident.of_long this
-
-(** Tabulated version of [const_check_interface_do]. *)
-and (const_check_interface: t -> Ident.long -> Lxm.t -> Eff.const) =
- fun this ->
- x_check_interface
- this.prov_consts SymbolTab.find_const const_check const_check_interface_do
- lookup_const_eff Ident.pack_of_long Ident.of_long this
-
-(** solving type and constant references *)
-and (solve_type_idref : t -> SymbolTab.t -> bool -> Ident.pack_name ->
- Ident.idref -> Lxm.t -> Eff.type_) =
- fun this symbols provide_flag currpack idr lxm ->
- solve_x_idref
- type_check_interface type_check SymbolTab.find_type "type"
- (fun p id -> Ident.make_long p id)
- this symbols provide_flag currpack idr [] lxm
-
-and (solve_const_idref : t -> SymbolTab.t -> bool -> Ident.pack_name ->
- Ident.idref -> Lxm.t -> Eff.const) =
- fun this symbols provide_flag currpack idr lxm ->
- solve_x_idref
- const_check_interface const_check SymbolTab.find_const "const"
- (fun p id -> Ident.make_long p id)
- this symbols provide_flag currpack idr [] lxm
-
-
-(* now the real work! *)
-and (type_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
- Ident.pack_name -> SyntaxTreeCore.type_info srcflagged ->
- Eff.type_) =
- fun this type_name lxm prov_symbols pack_name type_def ->
- (* We type check the interface and the body.
- For non-abstract types, we also check that both effective types are
- the same. *)
- let body_type_eff = type_check this type_name lxm in
- let prov_type_eff =
- type_check_do this type_name lxm prov_symbols true pack_name type_def
- in
- if Eff.type_are_compatible prov_type_eff body_type_eff then
- prov_type_eff
- else
- raise(Compile_error (
- type_def.src,
- ("provided type \n\t" ^
- (LicDump.string_of_type_eff4msg prov_type_eff) ^
- "\n is not compatible with its implementation \n\t" ^
- (LicDump.string_of_type_eff4msg body_type_eff))))
-
-
-and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
- Ident.pack_name -> SyntaxTreeCore.const_info srcflagged ->
- Eff.const) =
- fun this cn lxm prov_symbols p const_def ->
- let prov_const_eff = const_check_do this cn lxm prov_symbols true p const_def in
- let body_const_eff = const_check this cn lxm in
- match prov_const_eff, body_const_eff with
- | Eff.Extern_const_eff (_), _ -> assert false
- | Eff.Abstract_const_eff (id, teff, v, is_exported),
- Eff.Abstract_const_eff (body_id, body_teff, body_v, body_is_exported)
- ->
- assert false
- (* indeed, how can a body constant be extern and have a value? *)
-
- | Eff.Abstract_const_eff (id, teff, v, is_exported),
- Eff.Extern_const_eff (body_id, body_teff)
- ->
- if (id <> cn) then assert false
- else if not (Eff.type_are_compatible teff body_teff) then
- raise(Compile_error (
- const_def.src,
- ("provided constant type \n***\t" ^
- (LicDump.string_of_type_eff4msg teff) ^
- " is not compatible with its implementation \n***\t" ^
- (LicDump.string_of_type_eff4msg body_teff) ^ "")))
- else if
- is_exported
- then
- raise(Compile_error (const_def.src, " constant values mismatch"))
- else
- Eff.Extern_const_eff (body_id, body_teff)
-
- | Eff.Abstract_const_eff (id, teff, v, is_exported), _ ->
- let body_teff = Eff.type_of_const body_const_eff in
- if (id <> cn) then assert false
- else if not (Eff.type_are_compatible teff body_teff) then
- raise(Compile_error (
- const_def.src,
- ("provided constant type \n***\t" ^
- (LicDump.string_of_type_eff4msg teff) ^
- " is not compatible with its implementation \n***\t" ^
- (LicDump.string_of_type_eff4msg body_teff) ^ "")))
- else
- if is_exported && body_const_eff <> v then
- raise(Compile_error (const_def.src, " constant values mismatch"))
- else
- Eff.Abstract_const_eff (id, teff, body_const_eff, is_exported)
-
- | Eff.Enum_const_eff (_, _), _
- | Eff.Bool_const_eff _, _
- | Eff.Int_const_eff _, _
- | Eff.Real_const_eff _, _
- | Eff.Struct_const_eff (_,_), _
- | Eff.Array_const_eff (_,_), _
- ->
- if prov_const_eff = body_const_eff then
- body_const_eff
- else
- raise(Compile_error (
- const_def.src,
- "\n*** provided constant does not match with its definition."))
- | Eff.Tuple_const_eff _, _ ->
- print_internal_error "LazyCompiler.const_check_interface_do" "should not have been called for a tuple";
- assert false
-
-
-and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
- Ident.pack_name -> SyntaxTreeCore.type_info srcflagged ->
- Eff.type_) =
- fun this type_name lxm symbols provide_flag pack_name type_def ->
- try (
- (* Solveur d'idref pour les appels à eval_type/eval_const *)
- let id_solver = {
- id2var = (fun idref lxm -> raise (Unknown_var(lxm,idref)) (* should not occur *));
- id2const = solve_const_idref this symbols provide_flag pack_name;
- id2type = solve_type_idref this symbols provide_flag pack_name;
- id2node = solve_node_idref this symbols provide_flag pack_name;
- symbols = symbols;
- }
- in
- let type_eff =
- match type_def.it with
- | ArrayType _ -> finish_me " array handling "; assert false
- | ExternalType s -> (
- let lid = Ident.make_long pack_name s in
- let idref = Ident.idref_of_long lid in
- try
- Abstract_type_eff (lid, id_solver.id2type idref lxm)
- with e ->
- External_type_eff (lid)
- )
- | AliasedType (s, texp) -> GetEff.typ id_solver texp
- | EnumType (s, clst) -> (
- let n = Ident.make_long pack_name s in
- let add_pack_name x = Ident.make_long pack_name x.it in
- Enum_type_eff (n, List.map add_pack_name clst)
- )
- | StructType sti -> (
- let make_field (fname : Ident.t) =
- let field_def = Hashtbl.find sti.st_ftable fname in
- let teff = GetEff.typ id_solver field_def.it.fd_type in
- match field_def.it.fd_value with
- | None -> (fname, (teff, None))
- | Some vexp -> (
- let veff = EvalConst.f id_solver vexp in
- match veff with
- | [v] -> (
- let tv = Eff.type_of_const v in
- if (tv = teff) then (fname, (teff, Some v)) else
- raise
- (Compile_error(field_def.src, Printf.sprintf
- " this field is declared as '%s' but evaluated as '%s'"
- (LicDump.string_of_type_eff4msg teff)
- (LicDump.string_of_type_eff4msg tv)))
- )
- | [] -> assert false (* should not occur *)
- | _::_ ->
- raise (Compile_error(field_def.src,
- "bad field value: tuple not allowed"))
- )
- in
- let n = Ident.make_long pack_name sti.st_name in
- let eff_fields = List.map make_field sti.st_flist in
- Struct_type_eff (n, eff_fields)
- )
- in
- let is_struct_or_array = match type_eff with
- | Array_type_eff(_)
- | Struct_type_eff(_) -> true
- | Any | Overload | Bool_type_eff | Int_type_eff | Real_type_eff
- | External_type_eff(_) | Abstract_type_eff(_) | Enum_type_eff(_)
- -> false
- in
- if
- (not provide_flag)
- && (not (!Global.expand_structs & is_struct_or_array))
-(* && not !Global.ec (* ec does not need type decl at all *) *)
- then
- (* ICI IMPRESSION DE TYPE DECL OBSOLETE *)
- output_string !Global.oc (LicDump.type_decl type_name type_eff);
- type_eff
- )
- with
- (* capte et complete/stoppe les recursions *)
- Recursion_error (root, stack) ->
- if (root = type_name) then recursion_error type_def.src stack else
- raise ( Recursion_error (root, ("type ref "^(Lxm.details lxm))::stack))
-
-
-and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
- Ident.pack_name -> SyntaxTreeCore.const_info srcflagged ->
- Eff.const) =
- fun this cn lxm symbols provide_flag currpack const_def ->
- (* [cn] and [lxm] are used for recursion errors.
- [symbols] is the current symbol table.
- *)
- try (
- (* Solveur d'idref pour les les appels à eval_type/eval_const *)
- let id_solver = {
- id2var = (fun idref lxm -> assert false (* should not occur *));
- id2const = solve_const_idref this symbols provide_flag currpack;
- id2type = solve_type_idref this symbols provide_flag currpack;
- id2node = solve_node_idref this symbols provide_flag currpack;
- symbols = symbols;
- }
- in
- let const_eff =
- match const_def.it with
- | ExternalConst (id, texp, val_opt) ->
- let lid = Ident.make_long currpack id in
- let teff = GetEff.typ id_solver texp in
- if provide_flag then
- match val_opt with
- | None ->
- (* we put a fake value here as we don't know yet the
- concrete value. this will be filled in
- const_check_interface_do. I could have put an option
- type, but that would make quite a lot of noise in the
- remaining...
- *)
- Abstract_const_eff(lid, teff, Int_const_eff (-666), false)
- | Some c ->
- let ceff = match EvalConst.f id_solver c with
- | [ceff] -> ceff
- | _ -> assert false
- in
- Abstract_const_eff(lid, teff, ceff, true)
-
- else
- (match val_opt with
- | None -> Extern_const_eff(lid, teff)
- | Some c -> assert false
- (* indeed, how can a body constant be extern and have a value? *)
- )
- | EnumConst (id, texp) ->
- Enum_const_eff ((Ident.make_long currpack id), GetEff.typ id_solver texp)
-
- | DefinedConst (id, texp_opt, vexp ) -> (
- match (EvalConst.f id_solver vexp) with
- | [ceff] -> (
- match texp_opt with
- | None -> ceff
- | Some texp -> (
- let tdecl = GetEff.typ id_solver texp in
- let teff = Eff.type_of_const ceff in
- if (tdecl = teff ) then ceff else
- raise
- (Compile_error (const_def.src, Printf.sprintf
- " this constant is declared as '%s' but evaluated as '%s'"
- (LicDump.string_of_type_eff4msg tdecl)
- (LicDump.string_of_type_eff4msg teff)
- )))
- )
- | [] -> assert false (* should not occur *)
- | _::_ -> raise (Compile_error(const_def.src,
- "bad constant value: tuple not allowed"))
- )
- in
- let is_struct_or_array = match const_eff with
- | Struct_const_eff _ -> true
- | Array_const_eff _ -> true
- | _ -> false
- in
- let is_extern_const =
- match const_eff with
- | Enum_const_eff(_) ->
- !Global.expand_enums (* When expanding enums, we treat them as extern const *)
- && not provide_flag (* Avoid to define them twice *)
- | Extern_const_eff(_)
- -> true
- | _ -> false
- in
- if
- (not provide_flag
- && (not (!Global.expand_structs & is_struct_or_array))
- && (not !Global.ec) (* ec does not need constant decl, except extern ones *)
- ) || is_extern_const
- then
- (* ICI IMPRESSION DE CONST DECL OBSOLETE *)
- output_string !Global.oc (LicDump.const_decl cn const_eff);
-
- const_eff
- ) with Recursion_error (root, stack) -> (
- (* capte et complete/stoppe les recursions *)
- if (root = cn) then recursion_error const_def.src stack else
- (* on complete la stack *)
- raise (Recursion_error (root, ("const ref "^(Lxm.details lxm))::stack))
- )
-
-
-(******************************************************************************)
-
-
-
-and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
- SymbolTab.t -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
- Eff.node_exp) =
- fun this nk lxm symbols pn node_def ->
- let body_node_exp_eff = node_check this nk lxm in
- let prov_node_exp_eff = node_check_do this nk lxm symbols true pn node_def in
- (** [type_eff_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
- if t1 = t2 or t1 is abstract and and t2.
- *)
- let msg_prefix =
- ("provided node for " ^ (Ident.string_of_long (fst nk)) ^
- " is not compatible with its implementation: ")
- in
- let str_of_var = LicDump.type_string_of_var_info_eff4msg in
- let type_is_not_comp v1 v2 = not (Eff.var_are_compatible v1 v2) in
-
- (* Checking the type profile (w.r.t the body and the provided part) *)
- let ibtypes = List.map (fun v -> v.var_type_eff) body_node_exp_eff.inlist_eff
- and iptypes = List.map (fun v -> v.var_type_eff) prov_node_exp_eff.inlist_eff
- and obtypes = List.map (fun v -> v.var_type_eff) body_node_exp_eff.outlist_eff
- and optypes = List.map (fun v -> v.var_type_eff) prov_node_exp_eff.outlist_eff
- in
- let topt = UnifyType.profile_is_compatible nk
- node_def.src (iptypes,ibtypes) (optypes,obtypes)
- in
- let _ =
- (* the type profile seems ok, but it may need to unfreeze some
- polymorphic nodes *)
- match topt with
- | None -> ()
- | Some t -> GetEff.dump_polymorphic_nodes t
- in
- if
- prov_node_exp_eff.node_key_eff <> body_node_exp_eff.node_key_eff
- then
- raise(Compile_error (node_def.src, msg_prefix ^ " ??? "))
- else if
- (* ougth to be checked above: well, it eats no bread to keep that check *)
- (List.exists2 type_is_not_comp
- prov_node_exp_eff.inlist_eff body_node_exp_eff.inlist_eff)
- then
- let msg = msg_prefix ^ "bad input profile. \n*** " ^
- (String.concat "*" (List.map str_of_var prov_node_exp_eff.inlist_eff)) ^
- " <> " ^
- (String.concat "*" (List.map str_of_var body_node_exp_eff.inlist_eff))
- in
- raise(Compile_error (node_def.src, msg))
- else if
- (List.exists2 type_is_not_comp
- prov_node_exp_eff.outlist_eff body_node_exp_eff.outlist_eff)
- (* ougth to be checked above: well, it eats no bread to keep that check *)
- then
- let msg = msg_prefix ^ "bad output profile. \n*** " ^
- (String.concat "*" (List.map str_of_var prov_node_exp_eff.outlist_eff)) ^
- " <> " ^
- (String.concat "*" (List.map str_of_var body_node_exp_eff.outlist_eff))
- in
- raise(Compile_error (node_def.src, msg))
- else if
- prov_node_exp_eff.has_mem_eff <> body_node_exp_eff.has_mem_eff
- then
- raise(Compile_error (node_def.src, msg_prefix ^ " node or function?"))
- else if
- prov_node_exp_eff.is_safe_eff <> body_node_exp_eff.is_safe_eff
- then
- raise(Compile_error (node_def.src, msg_prefix ^ "safe or unsafe?"))
- else if
- match prov_node_exp_eff.def_eff, body_node_exp_eff.def_eff with
- | (AbstractEff _,_) -> false
- | (_,_) -> prov_node_exp_eff.def_eff <> body_node_exp_eff.def_eff
- then
- raise(Compile_error (node_def.src, msg_prefix ^ "abstract or not?"))
- else
- match prov_node_exp_eff.def_eff, body_node_exp_eff.def_eff with
- | AbstractEff None, BodyEff node_body ->
- { prov_node_exp_eff with def_eff = AbstractEff (Some body_node_exp_eff) }
- | _,_ ->
- prov_node_exp_eff
-
-and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
- bool -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
- Eff.node_exp) =
- fun this nk lxm symbols provide_flag pack_name node_def ->
- let lxm = node_def.src in
- (* Creates a local_env with just the global bindings,
- local bindinds will be added later (side effect)
- *)
- let local_env = make_local_env nk in
- let _ =
- Verbose.exe ~level:3
- ( fun () ->
- Printf.printf "*** local_env while entering (node_check_do %s):\n"
- (LicDump.string_of_node_key_rec nk);
- LicDump.dump_local_env local_env;
- flush stdout
- )
- in
- let node_id_solver = {
- (* a [node_id_solver] is a [id_solver] where we begin to look
- into the local environement before looking at the global
- one. *)
- id2var = (* var can only be local to the node *)
- (fun id lxm ->
- try lookup_var local_env (Ident.of_idref id) lxm
- with Not_found ->
- raise (Unknown_var(lxm,id))
- );
- id2const =
- (fun id lxm ->
- try lookup_const local_env id lxm
- with Not_found ->
- solve_const_idref this symbols provide_flag pack_name id lxm
- );
- id2type =
- (fun id lxm ->
- try lookup_type local_env id lxm
- with Not_found ->
- Verbose.exe ~level:3 (
- fun () ->
- Printf.printf "*** Dont find type %s in local_env\n" (Ident.string_of_idref id);
- Printf.printf "*** local_env.lenv_types contain def for: ";
- Hashtbl.iter
- (fun id t ->
- Printf.printf "%s, " (Ident.to_string id) )
- local_env.lenv_types;
- Printf.printf "\n";
- flush stdout);
- solve_type_idref this symbols provide_flag pack_name id lxm);
- id2node =
- (fun id sargs lxm ->
- (try
- let (node_id,sargs), inlist, outlist = 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 *)
-
- with
- Not_found ->
- solve_node_idref this symbols provide_flag pack_name id sargs lxm
- | _ -> assert false)
- );
-
- symbols = symbols;
- }
- in
- let make_node_eff id node_def_eff = (
- (* building not aliased nodes *)
- Verbose.exe ~level:3
- ( fun () ->
- Printf.printf "*** local_env while entering (make_node_eff %s):\n" (Ident.to_string id);
- LicDump.dump_local_env local_env
- );
- (********************************************************)
- (* LOCAL CONSTANTS are evaluated and added to local_env *)
- (********************************************************)
- (* init intermediate table *)
- let sz = List.length node_def.it.loc_consts in
- let temp_const_eff_tab : (Ident.long, Eff.const Eff.check_flag) Hashtbl.t =
- Hashtbl.create sz
- in
- let temp_const_def_tab :
- (Ident.t,(Lxm.t * SyntaxTreeCore.type_exp option * SyntaxTreeCore.val_exp)) Hashtbl.t =
- Hashtbl.create sz
- in
- let init_local_const (lxm, cinfo) = (
- match cinfo with
- | DefinedConst (i,topt,ve) -> (
- Verbose.printf ~level:3 " * local const %s will be treated\n" i;
- Hashtbl.add temp_const_def_tab i (lxm,topt,ve)
- )
- | ExternalConst _
- | EnumConst _ -> (
- let msg = "*** abstract constant bot allowed within node "
- in
- raise (Compile_error(lxm, msg))
- )
- ) in
- List.iter init_local_const node_def.it.loc_consts ;
- (* differs from node_id_solver only on id2const *)
- let rec local_id_solver = {
- id2var = node_id_solver.id2var;
- id2const = local_id2const;
- id2type = node_id_solver.id2type;
- id2node = node_id_solver.id2node;
- symbols = node_id_solver.symbols;
- }
- and treat_local_const id = (
- Verbose.printf ~level:3 " * call treat_local_const %s\n" id;
- let id_key = ("", id) in
- try (
- let ce = lookup_const_eff temp_const_eff_tab id_key lxm in
- Verbose.printf ~level:3 " * const %s already treated = %s\n"
- id (LicDump.string_of_const_eff ce);
- ce
- ) with Not_found -> (
- let (lxmdef, toptdef, vedef) = Hashtbl.find temp_const_def_tab id in
- Verbose.printf ~level:3 " * const %s not yet treated ...\n" id ;
- (* yes, not yet checked *)
- Hashtbl.add temp_const_eff_tab id_key Checking ;
- (* computes the value with EvalConst.f id_solver ve ... *)
- let ce = match (EvalConst.f local_id_solver vedef) with
- | [ceff] -> (
- match toptdef with
- | None -> ceff
- | Some texp -> (
- let tdecl = GetEff.typ local_id_solver texp in
- let teff = Eff.type_of_const ceff in
- if (tdecl = teff ) then ceff else
- raise (Compile_error (
- lxmdef, Printf.sprintf
- " this constant is declared as '%s' but evaluated as '%s'"
- (LicDump.string_of_type_eff4msg tdecl)
- (LicDump.string_of_type_eff4msg teff)
- )))
- )
- | [] -> assert false (* should not occur *)
- | _::_ -> raise (Compile_error(lxmdef, "bad constant value: tuple not allowed"))
- in
- Verbose.printf ~level:3 " * const %s evaluated to %s\n"
- id (LicDump.string_of_const_eff ce);
- Hashtbl.replace temp_const_eff_tab id_key (Checked ce) ;
- ce
- )
- )
- and local_id2const idrf lxm = (
- (* is id a local const ? *)
- try (
- (* certainly NOT if id has a pack *)
- let id = if (Ident.pack_of_idref idrf = None)
- then Ident.name_of_idref idrf
- else raise Not_found
- in
- let ce = treat_local_const id in
- ce
- ) with Not_found -> (
- (* not a local constant -> search in global env *)
- Verbose.printf ~level:3 " * %s not a local const, should be global ?" (Ident.string_of_idref idrf);
- let ce = node_id_solver.id2const idrf lxm in
- Verbose.printf ~level:3 " YES -> %s\n" (LicDump.string_of_const_eff ce);
- ce
- )
- ) in
- (* iters local_id2const n eeach declared constant *)
- Hashtbl.iter (fun id _ -> let _ = treat_local_const id in ()) temp_const_def_tab ;
- (* Finally, adds each local const to ICI *)
- let add_local_const idref ceck = (
- Verbose.printf ~level:3 " * add_local_const %s = %s\n"
- (snd idref)
- (match ceck with
- | Checking -> "Checking"
- | Checked ce -> (LicDump.string_of_const_eff ce)
- | Incorrect -> "Incorrect"
- );
- match ceck with
- | Checked ce -> Hashtbl.add local_env.lenv_const (snd idref) ce
- | _ -> assert false
- ) in
- Hashtbl.iter add_local_const temp_const_eff_tab ;
-
- (********************************************************)
- (* LOCAL FLOWS are added to local_env *)
- (********************************************************)
- (* (i.e. ins,outs,locs) *)
- match node_def.it.vars with
- | None -> assert false (* a node with a body should have a profile *)
- | Some vars ->
- let is_polymorphic = ref false in
- let type_args id =
- let vi = find_var_info lxm vars id in
- let t_eff = GetEff.typ node_id_solver vi.it.var_type in
- let _ = if Eff.is_polymorphic t_eff then is_polymorphic := true in
- let c_eff = GetEff.clock node_id_solver vi.it in
- let vi_eff = {
- var_name_eff = vi.it.var_name;
- var_nature_eff = vi.it.var_nature;
- var_number_eff = vi.it.var_number;
- var_type_eff = t_eff;
- var_clock_eff = c_eff;
- }
- in
- Hashtbl.add local_env.lenv_types id t_eff;
- Hashtbl.add local_env.lenv_vars id vi_eff;
- vi_eff
- in
- let (sort_vars : Ident.t list -> Ident.t list) =
- fun l ->
- (* I cannot use List.sort as I only have a partial order on vars
- -> hence I perform a topological sort *)
- let rec depends_on v1 v2 =
- match (find_var_info lxm vars v1).it.var_clock with
- | Base -> false
- | NamedClock({it=(_,v1clk)}) -> v1clk = v2 || depends_on v1clk v2
- in
- let rec aux acc l = match l with
- | [] -> acc
- | v::tail -> (
- match (find_var_info lxm vars v).it.var_clock with
- | Base ->
- if List.mem v acc then
- aux acc tail
- else
- aux (v::acc) tail
- | NamedClock( { it=(_,v2) ; src=lxm }) ->
- if List.mem v2 acc then
- aux (v::acc) tail
- else if
- depends_on v2 v
- then
- raise (
- Compile_error (
- lxm,
- "\n*** Clock dependency loop: " ^
- (Ident.to_string v) ^ " depends on " ^
- (Ident.to_string v2) ^ ", which depends on " ^
- (Ident.to_string v))
- )
- else
- let l1,l2 = List.partition (fun v -> v=v2) l in
- if l1 = [] then
- (* v depends on a clock not in l *)
- aux (v::acc) tail
- else
- aux acc (v2::l2)
- )
- in
- List.rev(aux [] l)
- in
- let vars_in_sorted = sort_vars vars.inlist
- and vars_out_sorted = sort_vars vars.outlist in
- let inlist = List.map type_args vars_in_sorted
- and outlist = List.map type_args vars_out_sorted
- and loclist =
- match vars.loclist with
- | None -> None
- | Some loclist ->
- let vars_loc_sorted = sort_vars loclist in
- Some (List.map type_args vars_loc_sorted)
- in
- let unsort l_id l_vi =
- let tab = List.map (fun vi -> vi.var_name_eff, vi) l_vi in
- try List.map (fun id -> List.assoc id tab) l_id
- with Not_found -> assert false
- in
- let inlist2 = unsort vars.inlist inlist
- and outlist2 = unsort vars.outlist outlist in
- {
- node_key_eff = nk;
- inlist_eff = inlist2;
- outlist_eff = outlist2;
- loclist_eff = loclist;
- def_eff = node_def_eff ();
- has_mem_eff = node_def.it.has_mem;
- is_safe_eff = node_def.it.is_safe;
- is_polym_eff = !is_polymorphic
- }
- ) in
- (* let's go *)
- let res =
- match node_def.it.def with
- | Abstract -> make_node_eff node_def.it.name (fun () -> AbstractEff None)
- | Extern -> make_node_eff node_def.it.name (fun () -> ExternEff)
- | Body nb ->
- make_node_eff node_def.it.name (
- (fun () -> (* trick to force to delay this evaluation
- after the local_env.lenv_vars has been
- filled
- *)
- let eq_eff = List.map (GetEff.eq node_id_solver) nb.eqs in
- BodyEff {
- asserts_eff =
- List.map (GetEff.assertion node_id_solver) nb.asserts;
- eqs_eff = eq_eff;
- }
- )
- )
-
- | 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
-
- | CALL_n(node_alias) ->
- GetEff.node node_id_solver node_alias
- | (MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _
- |IDENT_n _|ARRAY_n|HAT_n|CONCAT_n|WITH_n(_)|TUPLE_n|WHEN_n _
- |CURRENT_n|FBY_n|ARROW_n|PRE_n)
- ->
- raise (Compile_error (lxm, "can not alias this operator, sorry"))
- (* does it make sense to alias when, pre, etc? *)
- in
- let (vil, vol) =
- match node_def.it.vars with
- | None -> aliased_node.inlist_eff, aliased_node.outlist_eff
- | Some (vars) ->
- (* a type profile is declared; let's check there are compatible *)
- let (il,ol) = profile_of_node_exp aliased_node in
- let (il_decl, ol_decl) =
- let vi_il, vi_ol =
- List.map (fun id -> find_var_info lxm vars id) vars.SyntaxTreeCore.inlist,
- List.map (fun id -> find_var_info lxm vars id) vars.SyntaxTreeCore.outlist
- in
- let aux vi = GetEff.typ node_id_solver vi.it.var_type in
- let (il_decl, ol_decl) = List.map aux vi_il, List.map aux vi_ol in
- let i_unif_res = UnifyType.f il_decl il
- and o_unif_res = UnifyType.f ol_decl ol
- in
- (match i_unif_res with
- | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
- | UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
- );
- (match o_unif_res with
- | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
- | UnifyType.Equal -> ()
- | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t
- );
- (* ok, there are compatible. We use the declared profile. *)
- (il_decl, ol_decl)
- in
- let instanciate_var_info vi t = { vi with var_type_eff = t } in
- let vil = List.map2 instanciate_var_info aliased_node.inlist_eff il_decl
- and vol = List.map2 instanciate_var_info aliased_node.outlist_eff ol_decl in
- vil,vol
- in
- let (alias_node : Eff.node_exp) =
- try make_alias_node aliased_node nk local_env node_id_solver
- vil vol node_def.src
- with Not_found -> assert false (* defense against List.assoc *)
- in
-
- (* XXX useless ?? deja fait dans Eff.make_alias_node:564
- essayer d'enlever voir quand tout marchera.
- *)
- (* Check that the declared profile (if any) matches with the alias *)
-(* match node_def.it.vars with *)
-(* | None -> alias_node *)
-(* | Some vars -> *)
-(* let vi_il, vi_ol = *)
-(* List.map (fun id -> find_var_info lxm vars id) vars.inlist, *)
-(* List.map (fun id -> find_var_info lxm vars id) vars.outlist *)
-(* in *)
-(* let aux vi = GetEff.typ node_id_solver vi.it.var_type *)
-(* in *)
-(* let (il,ol) = Eff.profile_of_node_exp alias_node in *)
-(* let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in *)
-(* let i_unif_res = UnifyType.f il_exp il *)
-(* and o_unif_res = UnifyType.f ol_exp ol *)
-(* in *)
-(* (match i_unif_res with *)
-(* | UnifyType.Ko msg -> raise(Compile_error(lxm, msg)) *)
-(* | UnifyType.Equal -> () *)
-(* | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t *)
-(* ); *)
-(* (match o_unif_res with *)
-(* | UnifyType.Ko msg -> raise(Compile_error (lxm, msg)) *)
-(* | UnifyType.Equal -> () *)
-(* | UnifyType.Unif t -> GetEff.dump_polymorphic_nodes t *)
-(* ); *)
- alias_node
- )
- (* End Alias *)
- in
- let current_env = {
- local = local_env;
- global = node_id_solver;
- }
- in
- let res = source_to_source provide_flag current_env res in
- let _ = UniqueOutput.check res node_def.src in
- gen_code provide_flag current_env res;
- res
-
-(*
- [make_alias_node aliased_node alias_nk node_id_solver_vars_opt lxm]
- builds a node that calls the aliased node. It looks like:
- node alias_node(ins) returns (outs);
- let
- outs = aliased_node(ins);
- tel
-
- When instanciating models with polymorphic operators, it
- may happen that some exported user nodes become
- polymorphic (via node alias precisely). But in that case,
- a non-polymorphic profile is given in the package provided
- part. In such a case, we can use the types of the provided
- part (itl and otl) instead of the polymorphic ones. *)
-and (make_alias_node : node_exp -> node_key -> local_env -> id_solver ->
- var_info list -> var_info list -> Lxm.t -> node_exp) =
- fun aliased_node alias_nk local_env node_id_solver vil vol lxm ->
- Verbose.printf ~level:3 "*** Eff.make_alias_node %s \n" (Ident.long_to_string (fst alias_nk));
- flush stdout;
-
- let (outs:left list) = List.map (fun vi -> LeftVarEff (vi, lxm)) vol in
- let tl = List.map type_of_left outs in
- let cl = List.map (fun l -> (var_info_of_left l).var_clock_eff) outs in
- let (aliased_node_call : val_exp) =
- { core =
- CallByPosEff(
- (Lxm.flagit (CALL(Lxm.flagit aliased_node lxm)) lxm,
- OperEff
- (List.map
- (fun vi -> (* build operands*)
- let ve = {
- typ = [vi.var_type_eff];
- clk = [snd vi.var_clock_eff];
- core = CallByPosEff(
- Lxm.flagit (IDENT(
- Ident.to_idref vi.var_name_eff)) lxm, OperEff [])}
- in
- ve
- )
- vil)));
- typ = tl;
- clk = List.map snd cl;
- }
- in
- let alias_node =
- {
- aliased_node with
- node_key_eff = alias_nk;
- inlist_eff = vil;
- outlist_eff = vol;
- loclist_eff = None;
- def_eff = BodyEff(
- { asserts_eff = [];
- eqs_eff = [Lxm.flagit (outs, aliased_node_call) lxm]
- });
- is_polym_eff = List.exists is_polymorphic (List.map (fun vi -> vi.var_type_eff) (vil@vol));
- }
- in
- (* update the local_env table *)
- let _ =
- let update_local_env_table vi =
- Hashtbl.add local_env.lenv_vars vi.var_name_eff vi
- in
- List.iter update_local_env_table alias_node.inlist_eff;
- List.iter update_local_env_table alias_node.outlist_eff;
- match alias_node.loclist_eff with
- None -> () | Some l -> List.iter update_local_env_table l;
- in
- alias_node
-
-and gen_code (provide_flag:bool) (current_env:Eff.node_env) (nexp: Eff.node_exp) : unit =
-
- let nk = nexp.node_key_eff in
- let is_extern_oper =
- match nexp.def_eff with
- | ExternEff | AbstractEff None -> true
- | AbstractEff (Some _) | BodyEff _ -> false
- in
- let is_main_node =
- if !Global.main_node = "" then (
- (* if no main node is provided, we take the first node we find,
- that has a non-empty body. *)
- match nexp.def_eff with
- | ExternEff | AbstractEff _ -> false
- | BodyEff _ ->
- Global.main_node := Ident.string_of_long (fst nk);
- true
- )
- else
- (nk = (Ident.long_of_string !Global.main_node, []))
- in
- let nexp =
- if !Global.expand_nodes && is_main_node
- then NodesExpand.f current_env.local nexp
- else nexp
- in
- let nexp_struct =
- (* nb: we print res_struct, but do not return it from
- node_check, because the structure and array expansion
- modify (instanciate) the node profiles. *)
- if
- (!Global.expand_structs && not (nexp.is_polym_eff)
- && ((not !Global.expand_nodes || is_main_node) (* it is useless otherwise *)
- ) || is_extern_oper)
- then
- (
- Verbose.printf ~level:3 "-- Expand node %s \n" (Ident.long_to_string (fst nk));
- StructArrayExpand.node current_env.global current_env.local nexp
- )
- else
- nexp
- in
- if not provide_flag then
- (
- if not !Global.expand_nodes || is_extern_oper || is_main_node then
- if nexp.is_polym_eff then
- Polymorphism.push_on_polymorphic_node_stack (current_env, nexp_struct)
- else
- let str = LicDump.node_of_node_exp_eff nexp_struct in
- (* ICI IMPRESSION DE NODE DECL OBSOLETE *)
- output_string !Global.oc str
- );
-
-
-(* Apply various source to source transformations, according to command-line options ;
- + fix-point on generated nodes
-*)
-and source_to_source (provide_flag:bool) (current_env: Eff.node_env) (nexp: Eff.node_exp) : Eff.node_exp =
- let rec aux nl_done nl_todo =
- match nl_todo with
- | [] -> assert false
- | nexp::tail ->
- (*
- We need to split.node before Inline.iterators to be able to deal
- with equations like:
- x = n(map<<Lustre::iplus; 3>>(y);
- Indeed, Inline.iterators does not recursively inline its argument
- (it could, but it currently does not).
-
- Then, we need to split.node after Inline.iterators
- again because iterator inlining creates some equations
- that migth need some splitting...
- *)
- let _ = Name.reset_local_var_prefix "v" in (* coquetry *)
- let nexp =
- if !Global.one_op_per_equation
- then Split.node current_env nexp
- else nexp
- in
- let nexp =
- if !Global.inline_iterator
- then Inline.iterators current_env nexp
- else nexp
- in
- let nexp =
- if !Global.one_op_per_equation
- then Split.node current_env nexp
- else nexp
- in
- let nl_todo = tail in
- let nl_done = nl_done @ [nexp] in
- if nl_todo = [] then nl_done else aux nl_done nl_todo
- in
- match aux [] [nexp] with
- | [] -> assert false
- | nexp::new_nodes ->
- (* The main node is printed outside
- (indeed, we do not apply UniqueOutput.check only to generated nodes)
- *)
- List.iter (gen_code provide_flag current_env) new_nodes;
- nexp
-
-
-
-(** builds a [node_key] and calls [node_check] *)
-and (solve_node_idref : t -> SymbolTab.t -> bool -> Ident.pack_name -> Ident.idref ->
- Eff.static_arg list -> Lxm.t -> Eff.node_exp) =
- fun this symbols provide_flag currpack idr sargs lxm ->
- solve_x_idref
- node_check_interface node_check SymbolTab.find_node "node"
- (fun p id ->
- (* builds a [node_key] from a [pack_name] and a [node] id,
- and a Eff.static_arg list *)
- let long = Ident.make_long p id in
- let node_key = long, sargs in
- node_key
- )
- this symbols provide_flag currpack idr sargs lxm
-
-and (node_check: t -> Eff.node_key -> Lxm.t -> Eff.node_exp) =
- fun this nk lxm ->
- try
- x_check this.nodes SymbolTab.find_node node_check_do lookup_node_exp_eff
- (fun nk -> Ident.pack_of_long (fst nk))
- (fun nk -> Ident.of_long (fst nk))
- this nk lxm
- with
- Recursion_error (n, stack) ->
- let msg = "Recursion loop detected in node " ^ (Ident.string_of_long (fst nk)) in
- let msg = msg ^ "\n*** "^ (Ident.string_of_long n) ^ " depends on itself\n "
- ^ (String.concat "\n*****" stack) in
- raise (Compile_error (lxm, msg))
-
-and (node_check_interface:
- t -> Eff.node_key -> Lxm.t -> Eff.node_exp) =
- fun this nk ->
- x_check_interface this.prov_nodes SymbolTab.find_node node_check
- node_check_interface_do lookup_node_exp_eff
- (fun nk -> Ident.pack_of_long (fst nk))
- (fun nk -> Ident.of_long (fst nk)) this nk
-
-
-
-(*-------------------------------------------------------------------------
-compile all items
- ---------------------------------------------------------------------------*)
-
-let compile_all_item this label x_check_interface string_of_x_key
- string_of_x_eff to_key id item_def =
- match item_def with
- | SymbolTab.Local _item_def ->
- ignore
- (x_check_interface this (to_key id) (Lxm.dummy "compile all items"))
-(* Printf.printf "\t\t%s %s = %s\n" *)
-(* label (string_of_x_key (to_key id)) (string_of_x_eff x_eff) *)
-
- | SymbolTab.Imported(item_def,_) -> ()
-(* Printf.printf "\t\t%s %s = %s (imported)\n" *)
-(* label (string_of_x_key (to_key id)) (Ident.string_of_long item_def) *)
-
-
-let compile_all_types pack_name this =
- compile_all_item this "type" type_check_interface Ident.string_of_long
- LicDump.string_of_type_eff4msg (fun id -> Ident.make_long pack_name id)
-
-let compile_all_constants pack_name this =
- compile_all_item this "const" const_check_interface Ident.string_of_long
- LicDump.string_of_const_eff (fun id -> Ident.make_long pack_name id)
-
-
-let (get_static_params : (node_info Lxm.srcflagged) SymbolTab.elt ->
- static_param srcflagged list) =
- fun node_info_flagged ->
- match node_info_flagged with
- | SymbolTab.Local nif -> nif.it.static_params
- | SymbolTab.Imported(id,sparams) -> sparams
-
-let compile_all_nodes pack_name this id ni_f =
- let sp = get_static_params ni_f in
- if sp <> [] then () (* we need static arg to compile such kind of things *)
- else
- compile_all_item this "node" node_check_interface
- (LicDump.string_of_node_key_rec)
- Eff.profile_of_node_exp
- (fun id -> (Ident.make_long pack_name id, [])) id ni_f
-
-(**** to_lic : translate the (finalized) internal structure
- into a proper LicPrg, for forthcoming manip and other prg 2 prg
- transformations
- N.B. items belonging to the "Lustre" virtual pack are not
- taken into account
-*)
-
-let to_lic (this:t) : LicPrg.t =
- (* normally, only checked and correct programs are lic'ified *)
- let unflag = function Checked x -> x | _ -> assert false in
- let add_item add_x k v prg =
- match Ident.pack_of_long k with
- | "Lustre" -> prg
- | _ -> add_x k (unflag v) prg
- in
- let add_node k v prg =
- match Ident.pack_of_long (fst k) with
- | "Lustre" -> prg
- | _ -> LicPrg.add_node k (unflag v) prg
- in
- let res = LicPrg.empty in
- let res = Hashtbl.fold (add_item LicPrg.add_type) this.types res in
- let res = Hashtbl.fold (add_item LicPrg.add_const) this.consts res in
- let res = Hashtbl.fold add_node this.nodes res in
- res
-
-(**** Entry points of the module :
- either compile a single node or everithing ...
-*)
-let compile_all (this:t) : LicPrg.t =
- let testpack pack_name = (
- Verbose.printf ~level:3 " * package %s\n" (Ident.pack_name_to_string pack_name);
- let prov_symbols =
- match SyntaxTab.pack_prov_env this.src_tab pack_name (Lxm.dummy "") with
- | Some tab -> tab
- | None -> SyntaxTab.pack_body_env this.src_tab pack_name
- in
- Verbose.print_string ~level:3 "\tExported types:\n";
- SymbolTab.iter_types prov_symbols (compile_all_types pack_name this);
- flush stdout;
- Verbose.print_string ~level:3 "\tExported constants:\n";
- SymbolTab.iter_consts prov_symbols (compile_all_constants pack_name this);
- flush stdout;
- Verbose.print_string ~level:3 "\tExported nodes:\n";
- SymbolTab.iter_nodes prov_symbols (compile_all_nodes pack_name this);
- flush stdout
- )
- in
- let plist = SyntaxTab.pack_list this.src_tab in
- Verbose.print_string ~level:3 "*** Dump the exported items of the packages.\n";
- try
- List.iter testpack plist;
- to_lic this
- with
- Recursion_error (n, stack) ->
- let msg = "Recursion loop detected in node " ^ (Ident.string_of_long n) in
- let msg = msg ^ "\n*****" ^ (String.concat "\n*****" stack) in
- raise (Compile_error (Lxm.dummy "", msg))
-
-let compile_node (this:t) (main_node:Ident.idref) : LicPrg.t =
- (* la clée "absolue" du main node (pas d'args statiques) *)
- let main_node_key =
- Eff.make_simple_node_key (Ident.long_of_idref main_node)
- in
- Verbose.printf
- "-- MAIN NODE: \"%s\"\n"
- (LicDump.string_of_node_key_rec main_node_key);
-
- let lxm = match Ident.pack_of_idref main_node with
- | None -> Lxm.dummy ""
- | Some pn -> Lxm.dummy (Ident.pack_name_to_string pn)
- in
- let _ = node_check this main_node_key lxm in
- to_lic this
-
diff --git a/src/polymorphism.ml b/src/polymorphism.ml
deleted file mode 100644
index bc30f9af0d797c1587e41e5cd9145657735a2381..0000000000000000000000000000000000000000
--- a/src/polymorphism.ml
+++ /dev/null
@@ -1,48 +0,0 @@
-
-open Eff
-
-(* exported *)
-exception Exc
-
-let type_ref = ref None
-
-(* exported *)
-let get_type () =
- match !type_ref with
- | None -> raise Exc
- | Some t -> t
-
-
-let (set_type : Eff.type_ -> unit) =
- fun t ->
- type_ref := Some t
-
-(* exported *)
-let (reset_type : unit -> unit) = (* To be called in order to avoid silent bugs *)
- fun () ->
- type_ref := None
-
-
-(******************************************************************************)
-
-let polymorphic_node_stack : (Eff.node_env * Eff.node_exp) Stack.t = Stack.create ()
-
-(* exported *)
-let (push_on_polymorphic_node_stack : Eff.node_env * Eff.node_exp -> unit) =
- fun n ->
- Stack.push n polymorphic_node_stack
-
-(* exported *)
-let (unstack_polymorphic_nodes :
- Eff.type_ -> (Eff.node_env * Eff.node_exp) list) =
- fun t ->
- let _ = set_type t in
- let rec aux l =
- if Stack.is_empty polymorphic_node_stack then l else
- let x = Stack.pop polymorphic_node_stack in
- x::(aux l)
- in
- let res = aux [] in
- res
-
-
diff --git a/src/polymorphism.mli b/src/polymorphism.mli
deleted file mode 100644
index f37cc0f13bca98971606281fb8ac9019741a1b88..0000000000000000000000000000000000000000
--- a/src/polymorphism.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(** Handling polymorphic nodes.
-
- XXX I'm not particularly happy with the way all this is done...
-
- Anyway, the idea is the following. As soon as we try (in
- LazyCompiler) to dump a polymorphic node, we push it on a stack
- (push_on_polymorphic_node_stack), instead of dumping it, as we
- have decided that lic does not accept polymorphic nodes. This
- ougth to occur in a unique situation: when an array iterator is
- called over a polymorphic operator, e.g., in x =
- map<<+,3>>([1;2;3],[1;2;3]);
-
- in such a situation, we do generate a polymorphic Eff.node_exp
- for the expression "map<<+,3>>" (but we don't LicDump it). But
- once we get that node_exp (in GetEff.translate_val_exp), by
- unifying the node_exp with the dynamic arguments, we know that
- the type variable was (here, an integer). Hence, we can now
- print the instanciated node (unstack_polymorphic_nodes).
-
- Note that it is a stack because array iterators can be nested.
-
-*)
-
-
-(* To deal with polymorphism: raised when a polymorphic expr is generated. *)
-exception Exc
-
-
-val get_type : unit -> Eff.type_
-
-(* Should be unnecessary, but calling it at the appriopriate
- place would avoid silent bugs *)
-val reset_type : unit -> unit
-
-val push_on_polymorphic_node_stack : Eff.node_env * Eff.node_exp -> unit
-
-(** We have added the StructArrayExpand.node and Inline.iterators
- functions as parameter of this function to break module
- dependency loops.
-*)
-val unstack_polymorphic_nodes : Eff.type_ -> (Eff.node_env * Eff.node_exp) list
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index 0f9023f57b8454d226f07bd972e5260af3d69f85..425d8a15413f6b1ac730bd5f955d05747b1208aa 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -323,6 +323,9 @@ let (f : op -> Lxm.t -> Eff.static_arg list -> typer) =
let l = List.flatten ll in
if (List.length l <> List.length lti) then
arity_error "" (List.length l) (List.length lti)
+ else if (l = []) then
+ (* useless to call UnifyType.f ! *)
+ lto
else
match UnifyType.f lti l with
| Equal -> lto
diff --git a/src/structArrayExpand.ml b/src/structArrayExpand.ml
index b51c9a73585b35ee6681914e92fd968ce4276b11..74d06498d756096c6881e0513eb5385c83008e48 100644
--- a/src/structArrayExpand.ml
+++ b/src/structArrayExpand.ml
@@ -61,7 +61,10 @@ let clone_var node_env vi str type_eff =
let id = Ident.of_string (str) in
let clk_id = Ident.of_string str in
let type_eff = match type_eff with
- Any | Overload -> Polymorphism.get_type ()
+ Any | Overload ->
+ Errors.print_internal_error "StructArrayExpand.clone" "should not have been called for a any(num) var";
+ assert false
+
| _ -> type_eff
in
let var =
@@ -80,7 +83,9 @@ let clone_var node_env vi str type_eff =
let rec (is_a_basic_type : Eff.type_ -> bool) =
function
| Array_type_eff _ | Struct_type_eff _ -> false
- | Any | Overload -> is_a_basic_type (Polymorphism.get_type ())
+ | Any | Overload ->
+ Errors.print_internal_error "StructArrayExpand.is_a_basic_type" "should not have been called for a any(num) var";
+ assert false
| Abstract_type_eff(_, teff) -> is_a_basic_type teff
| External_type_eff(_)
| Enum_type_eff (_, _)
@@ -143,9 +148,8 @@ let rec (gen_var_trees :
let loop = gen_var_trees make_leave in
match teff with
| Any | Overload ->
- let teff = Polymorphism.get_type () in
- L (make_leave prefix teff)
-
+ Errors.print_internal_error "StructArrayExpand.gen_var_trees" "should not have been called for a any(num) var";
+ assert false
| Bool_type_eff | Int_type_eff | Real_type_eff
| Enum_type_eff(_) | External_type_eff(_)
->
@@ -511,7 +515,9 @@ and (expand_var_info: Eff.local_env -> Eff.id_solver -> var_info list * acc ->
let rec aux teff =
match teff with
| Abstract_type_eff (_, teff) -> aux teff
- | Any | Overload -> aux (Polymorphism.get_type ())
+ | Any | Overload ->
+ Errors.print_internal_error "StructArrayExpand.expand_var_info" "should not have been called for a any(num) var";
+ assert false
| Struct_type_eff (name, fl) ->
List.fold_left
(fun (vil,acc) (fn, (ft,_const_opt)) ->