From 5116704fd178335ca68511a119c613ff47834f55 Mon Sep 17 00:00:00 2001
From: pascal <pascal@babasse.(none)>
Date: Sat, 7 Jul 2012 17:17:25 +0200
Subject: [PATCH] encore un pas
---
Makefile | 1 +
map.lus | 2 +-
src/compile.ml | 2 +
src/doAliasTypes.ml | 116 +++
src/eff.ml | 9 +
src/lazyCompiler.ml | 153 +---
src/lazyCompiler.save.ml | 1434 ++++++++++++++++++++++++++++++++++++++
src/licDump.ml | 26 +-
src/licDump.mli | 2 +
src/licPrg.ml | 23 +
src/licPrg.mli | 16 +-
src/main.ml | 9 +-
t.lus | 2 +
13 files changed, 1668 insertions(+), 127 deletions(-)
create mode 100644 src/doAliasTypes.ml
create mode 100644 src/lazyCompiler.save.ml
diff --git a/Makefile b/Makefile
index 9e429209..94d7dd62 100644
--- a/Makefile
+++ b/Makefile
@@ -96,6 +96,7 @@ SOURCES = \
$(OBJDIR)/getEff.ml \
$(OBJDIR)/nodesExpand.mli \
$(OBJDIR)/nodesExpand.ml \
+ $(OBJDIR)/doAliasTypes.ml \
$(OBJDIR)/lazyCompiler.ml \
$(OBJDIR)/lazyCompiler.mli \
$(OBJDIR)/compile.ml \
diff --git a/map.lus b/map.lus
index ee1ea4a4..faa3c841 100644
--- a/map.lus
+++ b/map.lus
@@ -1,5 +1,5 @@
-node titi = map<<+,4>>;
+--node titi = map<<+,4>>;
node toto(x,y: int^4) returns (o: int^4);
let
diff --git a/src/compile.ml b/src/compile.ml
index 0044a5f0..948be3a4 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -39,4 +39,6 @@ let (doit : SyntaxTree.pack_or_model list -> Ident.idref option -> unit) =
else
LazyCompiler.compile_node lzcomp main_node
in
+ (* alias des types array *)
+ let zelic = DoAliasTypes.doit zelic in
LicPrg.to_file !Global.oc zelic
diff --git a/src/doAliasTypes.ml b/src/doAliasTypes.ml
new file mode 100644
index 00000000..a429b7a2
--- /dev/null
+++ b/src/doAliasTypes.ml
@@ -0,0 +1,116 @@
+
+(*
+Source 2 source transformation :
+- toutes les expressions de types sans NOM
+ (donc uniquement des tableaux immédiats ?)
+ sont traquées et remplacées par un alias
+*)
+
+open Eff
+
+
+let doit (inp : LicPrg.t) : LicPrg.t =
+ let res = ref inp in
+ (* n.b. on fait un minumum d'effet de bord pour
+ pas avoir trop d'acummulateur ... *)
+
+ (** UTILE : nommage des alias d'array *)
+ let array_ident ty sz =
+ let tid = Eff.ident_of_type ty in
+ let id = Printf.sprintf "%s_%d" (snd tid) sz in
+ Ident.make_long (fst tid) id
+ in
+
+ (** UTILE : cherche/crée un alias de type *)
+ let rec alias_type te =
+ match te with
+ | Array_type_eff (ty, sz) -> (
+ let ty = alias_type ty in
+ let id = array_ident ty sz in
+ let te = Array_type_eff (ty, sz) in
+ let ref_te = Abstract_type_eff (id, te) in
+(*
+Verbose.printf "-> alias_type %s gives id=%s ref=%s\n"
+(LicDump.string_of_type_eff te)
+(Ident.string_of_long id)
+(LicDump.string_of_type_eff ref_te);
+*)
+ try
+ let te' = LicPrg.find_type !res id in
+ assert (te' = ref_te);
+ ref_te
+ with Not_found ->
+ res := LicPrg.add_type id ref_te !res;
+ ref_te
+ ) | _ -> te
+ in
+
+ (** TRAITE LES TYPES *)
+ let do_type k te =
+ let te' = match te with
+ | Array_type_eff (tel, sz) ->
+ let tel' = alias_type tel in
+ Array_type_eff (tel', sz)
+ | Struct_type_eff (id, fields) ->
+ let do_field (id, (tf, co)) =
+ (id, (alias_type tf, co))
+ in
+ Struct_type_eff (id, List.map do_field fields)
+ | _ -> te
+ in
+ if (te = te') then ()
+ else
+ res := LicPrg.add_type k te' !res
+ in
+ LicPrg.iter_types do_type inp;
+
+ (** TRAITE LES CONSTANTES *)
+ let do_const k ec =
+ let ec' = match ec with
+ | Extern_const_eff (i, te) ->
+ let te' = alias_type te in
+ Extern_const_eff (i, te')
+ | Abstract_const_eff (i, te, c, b) ->
+ let te' = alias_type te in
+ Abstract_const_eff (i, te', c, b)
+ | Array_const_eff (cl, te) ->
+ let te' = alias_type te in
+ Array_const_eff (cl, te')
+ | Bool_const_eff _
+ | Int_const_eff _
+ | Real_const_eff _
+ | Enum_const_eff _
+ | Struct_const_eff _
+ | Tuple_const_eff _ -> ec
+ in
+ if (ec = ec') then ()
+ else
+ (* n.b. add=replace *)
+ res := LicPrg.add_const k ec' !res
+ in
+ LicPrg.iter_consts do_const inp ;
+
+ (** TRAITE LES NOEUDS *)
+ let do_node k en =
+ (* n.b. les Eff.type_ apparraissent uniquement dans les var infos *)
+ let do_var vi =
+ let ty = alias_type vi.var_type_eff in
+ {vi with var_type_eff = ty}
+ in
+ let en' = { en with
+ inlist_eff = (List.map do_var en.inlist_eff);
+ outlist_eff = (List.map do_var en.outlist_eff);
+ loclist_eff = (
+ match en.loclist_eff with
+ | Some vl -> Some (List.map do_var vl)
+ | None -> None
+ )
+ } in
+ (* on fait pas dans la dentelle, on remplace ... *)
+ res := LicPrg.add_node k en' !res
+ in
+ LicPrg.iter_nodes do_node inp;
+ !res
+
+
+
diff --git a/src/eff.ml b/src/eff.ml
index 0e9cabdd..8a514ca0 100644
--- a/src/eff.ml
+++ b/src/eff.ml
@@ -466,6 +466,15 @@ let (var_are_compatible : var_info -> var_info -> bool) =
(type_are_compatible v1.var_type_eff v2.var_type_eff) &&
(clock_are_equals (snd v1.var_clock_eff) (snd v2.var_clock_eff))
+let ident_of_type = function
+ | Bool_type_eff -> Ident.long_of_string "bool"
+ | Int_type_eff -> Ident.long_of_string "int"
+ | Real_type_eff -> Ident.long_of_string "real"
+ | External_type_eff id
+ | Abstract_type_eff (id, _)
+ | Enum_type_eff (id, _)
+ | Struct_type_eff (id, _) -> id
+ | _ -> assert false
(****************************************************************************)
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 27575f9e..1dc699d7 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -502,8 +502,9 @@ and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
&& (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 *)
- output_string !Global.oc (LicDump.type_decl type_name type_eff);
+ (* ICI IMPRESSION DE TYPE DECL OBSOLETE *)
+ (* output_string !Global.oc (LicDump.type_decl type_name type_eff); *)
+ ();
type_eff
)
with
@@ -602,9 +603,9 @@ and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
&& (not !Global.ec) (* ec does not need constant decl, except extern ones *)
) || is_extern_const
then
-(* ICI IMPRESSION DE CONST DECL *)
- output_string !Global.oc (LicDump.const_decl cn const_eff);
-
+ (* 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 *)
@@ -1058,47 +1059,17 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
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 *)
+ 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;
+ (* gen_code provide_flag current_env res; *)
res
(*
@@ -1220,60 +1191,10 @@ and gen_code (provide_flag:bool) (current_env:Eff.node_env) (nexp: Eff.node_exp)
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 *)
- 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
-
-
+ (* ICI IMPRESSION DE NODE DECL OBSOLETE *)
+ (* output_string !Global.oc str *)
+ ()
+ )
(** builds a [node_key] and calls [node_check] *)
and (solve_node_idref : t -> SymbolTab.t -> bool -> Ident.pack_name -> Ident.idref ->
@@ -1365,8 +1286,8 @@ let compile_all_nodes pack_name this id ni_f =
*)
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
+ (* 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
@@ -1377,14 +1298,14 @@ let to_lic (this:t) : LicPrg.t =
| "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
+ 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 ...
+ either compile a single node or everithing ...
*)
let compile_all (this:t) : LicPrg.t =
let testpack pack_name = (
@@ -1409,7 +1330,7 @@ let compile_all (this:t) : LicPrg.t =
Verbose.print_string ~level:3 "*** Dump the exported items of the packages.\n";
try
List.iter testpack plist;
- to_lic this
+ to_lic this
with
Recursion_error (n, stack) ->
let msg = "Recursion loop detected in node " ^ (Ident.string_of_long n) in
@@ -1417,18 +1338,18 @@ let compile_all (this:t) : LicPrg.t =
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
+ (* 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/lazyCompiler.save.ml b/src/lazyCompiler.save.ml
new file mode 100644
index 00000000..69b902fe
--- /dev/null
+++ b/src/lazyCompiler.save.ml
@@ -0,0 +1,1434 @@
+(** 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/licDump.ml b/src/licDump.ml
index 59e8a03f..39cb7868 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -16,7 +16,9 @@ let (dump_long : Ident.long -> string) = fun x ->
(* let str = Ident.string_of_long id in *)
(* Str.global_replace (Str.regexp "::") "__" str *)
+(* OBSOLETE
let type_alias_table = Hashtbl.create 0
+*)
(******************************************************************************)
@@ -172,10 +174,19 @@ and string_of_type_eff = function
| Abstract_type_eff (name, t) -> prefix ^ (dump_long name)
(* string_of_type_eff t *)
| Enum_type_eff (name, _) -> prefix ^ (dump_long name)
- | Array_type_eff (ty, sz) -> array_alias ty sz
+ (*
+ OBSOLETE
+ | Array_type_eff (ty, sz) -> array_alias ty sz
+ *)
+ | Array_type_eff (ty, sz) ->
+ Printf.sprintf "%s%s^%d" prefix (string_of_type_eff ty) sz
| Struct_type_eff (name, _) -> prefix ^ (dump_long name)
- | Any -> string_of_type_eff (Polymorphism.get_type ())
- | Overload -> string_of_type_eff (Polymorphism.get_type ())
+ | Any -> "any"
+ (* assert false *)
+ (* string_of_type_eff (Polymorphism.get_type ()) *)
+ | Overload -> "anynum"
+ (* assert false *)
+ (* string_of_type_eff (Polymorphism.get_type ()) *)
and string_of_type_eff4msg = function
@@ -193,7 +204,10 @@ and string_of_type_eff4msg = function
(******************************************************************************)
+
(** Stuff to manage generated type alias
+
+OBSOLETE
Indeed instead of printing:
@@ -211,7 +225,6 @@ and string_of_type_eff4msg = function
Then, at the end, we will dump that table in the lic file.
This table is filled by [array_alias].
-*)
and (array_alias : Eff.type_ -> int -> string) =
fun t size ->
let array_t = Array_type_eff(t,size) in
@@ -233,6 +246,7 @@ and dump_type_alias oc =
with Polymorphism.Exc -> ()
)
type_alias_table
+*)
(******************************************************************************)
(* exported *)
@@ -623,13 +637,13 @@ and (const_decl: Ident.long -> Eff.const -> string) =
(match ceff with
| Enum_const_eff(id, t) ->
if !Global.expand_enums then
- (begin_str ^ ":"^(string_of_type_eff t) ^ ";\n")
+ (begin_str ^ " : "^(string_of_type_eff t) ^ ";\n")
else
(* generate abstract constant *)
""
| Extern_const_eff _
| Abstract_const_eff _ ->
- begin_str ^ ":" ^ (string_of_type_eff (Eff.type_of_const ceff)) ^
+ begin_str ^ " : " ^ (string_of_type_eff (Eff.type_of_const ceff)) ^
(* (if !Global.ec then ".\n" else *)
(";\n")
| Struct_const_eff _
diff --git a/src/licDump.mli b/src/licDump.mli
index 5e433de3..b90a6449 100644
--- a/src/licDump.mli
+++ b/src/licDump.mli
@@ -26,7 +26,9 @@ val string_of_slice_info_eff : Eff.slice_info -> string
(* Dump all the aliases that were introduced during the compilation process *)
+(* OBSOLETE
val dump_type_alias : out_channel -> unit
+*)
(* used for error msgs *)
diff --git a/src/licPrg.ml b/src/licPrg.ml
index 485ca027..014f149f 100644
--- a/src/licPrg.ml
+++ b/src/licPrg.ml
@@ -54,6 +54,29 @@ let empty = {
nodes = NodeKeyMap.empty
}
+(** RECHERCHE *)
+let find_type this k = ItemKeyMap.find k this.types
+let find_const this k = ItemKeyMap.find k this.consts
+let find_node this k = NodeKeyMap.find k this.nodes
+
+
+(** PARCOURS *)
+let fold_consts (f: Eff.item_key -> Eff.const -> 'a -> 'a) (this:t) (accin:'a) : 'a =
+ ItemKeyMap.fold f this.consts accin
+let fold_types (f: Eff.item_key -> Eff.type_ -> 'a -> 'a) (this:t) (accin:'a) : 'a =
+ ItemKeyMap.fold f this.types accin
+let fold_nodes (f: Eff.node_key -> Eff.node_exp -> 'a -> 'a) (this:t) (accin:'a) : 'a =
+ NodeKeyMap.fold f this.nodes accin
+
+let iter_consts (f: Eff.item_key -> Eff.const -> unit) (this:t) : unit =
+ ItemKeyMap.iter f this.consts
+let iter_types (f: Eff.item_key -> Eff.type_ -> unit) (this:t) : unit =
+ ItemKeyMap.iter f this.types
+let iter_nodes (f: Eff.node_key -> Eff.node_exp -> unit) (this:t) : unit =
+ NodeKeyMap.iter f this.nodes
+
+
+
let add_type (k:Eff.item_key) (v:Eff.type_) (prg:t) : t =
{ prg with types = ItemKeyMap.add k v prg.types }
diff --git a/src/licPrg.mli b/src/licPrg.mli
index d600d081..5925a6bc 100644
--- a/src/licPrg.mli
+++ b/src/licPrg.mli
@@ -1,12 +1,24 @@
type t
-val empty : t
-
val add_type : Eff.item_key -> Eff.type_ -> t -> t
val add_const : Eff.item_key -> Eff.const -> t -> t
val add_node : Eff.node_key -> Eff.node_exp -> t -> t
+val empty : t
+
+(* fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b *)
+
+val fold_consts : (Eff.item_key -> Eff.const -> 'a -> 'a) -> t -> 'a -> 'a
+val fold_types : (Eff.item_key -> Eff.type_ -> 'a -> 'a) -> t -> 'a -> 'a
+val fold_nodes : (Eff.node_key -> Eff.node_exp -> 'a -> 'a) -> t -> 'a -> 'a
+
+val iter_consts : (Eff.item_key -> Eff.const -> unit) -> t -> unit
+val iter_types : (Eff.item_key -> Eff.type_ -> unit) -> t -> unit
+val iter_nodes : (Eff.node_key -> Eff.node_exp -> unit) -> t -> unit
val to_file : out_channel -> t -> unit
+val find_type : t -> Eff.item_key -> Eff.type_
+val find_const : t -> Eff.item_key -> Eff.const
+val find_node : t -> Eff.node_key -> Eff.node_exp
diff --git a/src/main.ml b/src/main.ml
index 6d31f2cf..61cf8db4 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -328,6 +328,7 @@ let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
p::packed_list
+(*
let dump_entete oc =
let time = Unix.localtime (Unix.time ()) in
let sys_call, _ = Array.fold_left
@@ -362,6 +363,7 @@ let dump_entete oc =
(* "by "^ user ^ *)
" the " ^ date ^ " at " ^ time_str ^ "\n\n");
flush oc
+*)
let my_exit i =
@@ -388,9 +390,12 @@ let main = (
Some (Ident.idref_of_string !Global.main_node)
in
if !Global.outfile <> "" then Global.oc := open_out !Global.outfile;
- dump_entete !Global.oc;
+ (* OBSOLETE *)
+ (* dump_entete !Global.oc; *)
Compile.doit nsl main_node;
- LicDump.dump_type_alias !Global.oc;
+ (* OBSOLETE
+ LicDump.dump_type_alias !Global.oc;
+ *)
if Verbose.get_level() > 2 then Gc.print_stat stdout;
close_out !Global.oc
) with
diff --git a/t.lus b/t.lus
index ba7a2e06..c8dd9a0d 100644
--- a/t.lus
+++ b/t.lus
@@ -7,3 +7,5 @@ type a = int^toto;
const c : t = Bleu;
const c2 : t;
+
+const t1 : bool^4^5;
--
GitLab