From e563a99d0318c3884b295151d53022f71c836dcf Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Mon, 25 Feb 2013 18:14:45 +0100
Subject: [PATCH] Plug the lic2loc files directly onto the Lic.
Indeed, the data structure in output of the lis2loc parser was very
similar to Lic.t/LicPrg.t. Hence, this shunt.
At this stage it compiles, but it's untested and does not work.
---
Makefile | 15 ++
src/actionsDeps.ml | 214 +++++++++++++++
src/actionsDeps.mli | 48 ++++
src/compile.ml | 8 +-
src/errors.ml | 2 +-
src/lic.ml | 7 +-
src/lic2soc.ml | 628 ++++++++++++++++++++++++++++++++++++++++++++
src/lic2soc.mli | 3 +
src/soc.ml | 64 +++++
src/socPredef.ml | 523 ++++++++++++++++++++++++++++++++++++
src/socPredef.mli | 19 ++
src/socUtils.ml | 361 +++++++++++++++++++++++++
src/socUtils.mli | 42 +++
src/toposort.ml | 39 +++
src/toposort.mli | 14 +
test/lus2lic.sum | 2 +-
test/lus2lic.time | 2 +-
17 files changed, 1984 insertions(+), 7 deletions(-)
create mode 100644 src/actionsDeps.ml
create mode 100644 src/actionsDeps.mli
create mode 100644 src/lic2soc.ml
create mode 100644 src/lic2soc.mli
create mode 100644 src/soc.ml
create mode 100644 src/socPredef.ml
create mode 100644 src/socPredef.mli
create mode 100644 src/socUtils.ml
create mode 100644 src/socUtils.mli
create mode 100644 src/toposort.ml
create mode 100644 src/toposort.mli
diff --git a/Makefile b/Makefile
index df88731e..3ca5f4ca 100644
--- a/Makefile
+++ b/Makefile
@@ -34,6 +34,20 @@ ifeq ($(HOSTTYPE),cygwin)
CFLAGS=-mno-cygwin
endif
+SOC_SOURCES = \
+ $(OBJDIR)/soc.ml \
+ $(OBJDIR)/socUtils.mli \
+ $(OBJDIR)/socUtils.ml \
+ $(OBJDIR)/socPredef.mli \
+ $(OBJDIR)/socPredef.ml \
+ $(OBJDIR)/toposort.mli \
+ $(OBJDIR)/toposort.ml \
+ $(OBJDIR)/actionsDeps.mli \
+ $(OBJDIR)/actionsDeps.ml \
+ $(OBJDIR)/lic2soc.mli \
+ $(OBJDIR)/lic2soc.ml
+
+
SOURCES = \
$(OBJDIR)/version.ml \
$(OBJDIR)/verbose.mli \
@@ -69,6 +83,7 @@ SOURCES = \
$(OBJDIR)/licDump.ml \
$(OBJDIR)/licPrg.mli \
$(OBJDIR)/licPrg.ml \
+ $(SOC_SOURCES) \
$(OBJDIR)/unifyType.mli \
$(OBJDIR)/unifyType.ml \
$(OBJDIR)/unifyClock.mli \
diff --git a/src/actionsDeps.ml b/src/actionsDeps.ml
new file mode 100644
index 00000000..316877e2
--- /dev/null
+++ b/src/actionsDeps.ml
@@ -0,0 +1,214 @@
+(** Time-stamp: <modified the 21/02/2013 (at 11:12) by Erwan Jahier> *)
+
+
+(* exported *)
+type inputs = Soc.var_expr list
+type outputs = Soc.var_expr list
+type action = Lic.clock * inputs * outputs * Soc.atomic_operation * Lxm.t
+
+
+(*********************************************************************************)
+let string_of_action: (action -> string) =
+ fun (c, i, o, p, lxm) ->
+ (* Version surchargée de Soc.string_of_operation pour afficher les "=" *)
+ let string_of_operation = function
+ | Soc.Assign -> ""
+ | op -> SocUtils.string_of_operation op
+ in
+ let string_of_params p = String.concat ", " (List.map SocUtils.string_of_filter p) in
+ if o = [] then
+ Format.sprintf "%s(%s)"
+ (string_of_operation p)
+ (string_of_params i)
+ else
+ Format.sprintf "%s = %s(%s) on %s"
+ (string_of_params o)
+ (string_of_operation p)
+ (string_of_params i)
+ (Lic.string_of_clock c)
+
+let string_of_action_simple: (action -> string) =
+ fun (c, i, o, p,_) ->
+ (* Version surchargée de SocUtils.string_of_operation : l'objectif est d'afficher,
+ en cas de cycle combinatoire, un message d'erreur que parle le plus possible
+ à l'utilisateur qui a programmé en V6... Pour cela le mieux (je pense) est
+ simplement de rendre la variable sur laquelle porte
+*)
+ let string_of_operation = function
+ | Soc.Assign -> ""
+ | op -> SocUtils.string_of_operation op
+ in
+ let string_of_params p = String.concat ", " (List.map SocUtils.string_of_filter p) in
+ if o = [] then
+ Format.sprintf "%s(%s)"
+ (string_of_operation p)
+ (string_of_params i)
+ else
+ Format.sprintf "%s = %s(%s)"
+ (string_of_params o)
+ (string_of_operation p)
+ (string_of_params i)
+
+
+(*********************************************************************************)
+module OrderedAction = struct
+ type t = action
+ let compare = compare
+end
+(** Gère un ensemble d'actions uniques. *)
+module Actions = Set.Make(OrderedAction)
+
+module MapAction = Map.Make(OrderedAction)
+
+(** maps an action to the set of actions that it depends on *)
+(* exported *)
+type t = Actions.t MapAction.t
+
+(* exported *)
+let empty: t = MapAction.empty
+
+(* exported *)
+let (find_deps: t -> action -> action list) =
+ fun m a ->
+ try Actions.elements (MapAction.find a m) with Not_found -> []
+
+(*********************************************************************************)
+(** Ajoute une liste de dépendances à une action. *)
+let add_deps: t -> action -> action list -> t = fun m a -> function
+ | [] -> m
+ | al ->
+ let actions = try MapAction.find a m with Not_found -> Actions.empty in
+ let actions = List.fold_left (fun set a -> Actions.add a set) actions al in
+ MapAction.add a actions m
+
+(* exported *)
+let (concat: t -> t -> t) =
+ fun m1 m2 ->
+ MapAction.fold (fun key value m -> add_deps m key (Actions.elements value)) m1 m2
+
+(*********************************************************************************)
+(* exported *)
+let (generate_deps_from_step_policy:
+ Soc.precedence list -> (string * action) list -> t) =
+ fun precedences actions ->
+ let generate_deps_for_action:
+ (t -> string * string list -> t) =
+ fun ad (action_name, actions_needed) ->
+ let main_action = snd (List.find (fun (n, _) -> n = action_name) actions) in
+ let deps =
+ List.map
+ (fun dep_name -> snd (List.find (fun (n, _) -> n = dep_name) actions))
+ actions_needed
+ in
+ add_deps ad main_action deps
+ in
+ List.fold_left (generate_deps_for_action) empty precedences
+
+
+(*********************************************************************************)
+module OrderedSocVar = struct
+ type t = Soc.var_expr
+ let compare = compare
+end
+module VarMap = Map.Make(OrderedSocVar)
+
+(** A Data structure that maps a Soc.var_expr to all the
+ actions that use that variable in outputs.
+
+ It is used to know which actions impact which outputs.
+*)
+type var2actions_tbl = Actions.t VarMap.t
+
+
+(** TODO jb: On a peut-être pas besoin de stocker les actions dans des set, il
+ devrait n'y avoir qu'une seule action pour chaque sortie en théorie (?)
+*)
+let (get_var2actions_tbl : action list -> var2actions_tbl) =
+ fun al ->
+ let (tabulate_action : var2actions_tbl -> action -> var2actions_tbl) =
+ fun tbl action ->
+ let _, _, outputs, _, lxm = action in
+ let (tabulate_output:var2actions_tbl -> Soc.var_expr -> var2actions_tbl) =
+ fun tbl output ->
+ let tabulate_action = try VarMap.find output tbl
+ with Not_found -> Actions.empty
+ in
+ VarMap.add output (Actions.add action tabulate_action) tbl
+ in
+ List.fold_left tabulate_output tbl outputs
+ in
+ List.fold_left tabulate_action VarMap.empty al
+
+
+(** Returns the actions that depends on a set of vars.
+
+ [find_input_deps input_vars al] trouve toutes les actions de [al] qui
+ ont besoin d'être effectuées avant de pouvoir se servir de [input_vars]
+ comme entrée d'une autre action.
+
+ TODO: gérer les dépendances entre des filtres plus complexes,
+ comme par ex., l'utilisation d'un champ d'une structure nécessite
+ d'avoir initialisé la structure parente.
+*)
+let rec (find_input_deps: Soc.var_expr list -> var2actions_tbl -> action list) =
+ fun input_vars tbl ->
+ let find_deps i =
+ try Actions.elements (VarMap.find i tbl)
+ with Not_found -> []
+ in
+ List.flatten (List.map find_deps input_vars)
+
+(*********************************************************************************)
+
+(* exported *)
+let build_data_deps_from_actions: t -> action list -> t =
+ fun deps al ->
+ let tbl = get_var2actions_tbl al in
+ let deps =
+ List.fold_left
+ (fun acc_deps action ->
+ let (_, inputs, _, _,_) = action in
+ let deps = find_input_deps inputs tbl in
+ if deps = [] then acc_deps else add_deps acc_deps action deps
+ )
+ deps
+ al
+ in
+ deps
+
+
+
+(*********************************************************************************)
+(*********************************************************************************)
+(*********************************************************************************)
+
+(* Some Printers to ease the debugging *)
+(** Printer pour [Actions.t] *)
+let string_of_actions: Actions.t -> string = fun s ->
+ let to_string a acc =
+ acc ^ (string_of_action a) ^ " ; "
+ in
+ "Actions(" ^ (Actions.fold to_string s "") ^ ")"
+
+let to_string: t -> string = fun m ->
+ let to_string key value acc =
+ let entry =
+ Format.sprintf "%s \n depends on « %s »"
+ (string_of_action key)
+ (string_of_actions value)
+ in
+ acc ^ entry ^ "\n"
+ in
+ "ActionsDeps{\n" ^ (MapAction.fold to_string m "") ^ "}"
+
+let string_of_var2actions_tbl: var2actions_tbl -> string =
+ fun s ->
+ let to_string key value acc =
+ let entry = Format.sprintf "%s => %s" (SocUtils.string_of_filter key)
+ (string_of_actions value)
+ in
+ acc ^ entry ^ "\n"
+ in
+ "FilterAction{\n" ^ (VarMap.fold to_string s "") ^ "}"
+
+(*********************************************************************************)
diff --git a/src/actionsDeps.mli b/src/actionsDeps.mli
new file mode 100644
index 00000000..69613360
--- /dev/null
+++ b/src/actionsDeps.mli
@@ -0,0 +1,48 @@
+(** Time-stamp: <modified the 21/02/2013 (at 11:11) by Erwan Jahier> *)
+
+(** Compute dependencies between actions *)
+
+
+type t
+
+val empty : t
+
+(** Linear in the size of the first parameter *)
+val concat: t -> t -> t
+
+
+(** An action is an intermediary data type that is used to translate expressions
+ into [Soc.gao]. It is basically a clocked Soc.atomic_operation with arguments.
+
+ The idea is that each expression is translated into one or several actions.
+ And those clocks are then translated into guards, so that each action is
+ translated into a gao.
+
+ A more natural Module to define that type in would have been Soc, but that
+ module is meant to be shared with other front-ends (e.g., lucid-synchrone),
+ and I prefer that module not to depend on
+ - such a cutting (expr -> action -> gao)
+ - The [Eff.clock] name (could have been a module parameter though).
+ *)
+
+type inputs = Soc.var_expr list
+type outputs = Soc.var_expr list
+type action = Lic.clock * inputs * outputs * Soc.atomic_operation * Lxm.t
+
+val string_of_action_simple: action -> string
+
+
+(** Compute the action dependencies that comes from the I/O.
+
+ Construit des dépendances entre les actions en reliant les entrées et
+ les sorties de ces actions.
+*)
+val build_data_deps_from_actions: t -> action list -> t
+
+(** Use the dependency constraints that come from the SOC (e.g., 'get' before 'set'
+ in memory SOC).
+*)
+val generate_deps_from_step_policy: Soc.precedence list -> (string * action) list -> t
+
+(** Returns the list of actions that depends on the action in argument. *)
+val find_deps: t -> action -> action list
diff --git a/src/compile.ml b/src/compile.ml
index ca8b7a79..0c47a64d 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/02/2013 (at 14:56) by Erwan Jahier> *)
+(* Time-stamp: <modified the 25/02/2013 (at 18:13) by Erwan Jahier> *)
open Lxm
open Errors
@@ -68,5 +68,11 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
(* Currently only works in this mode *)
if !Global.ec then L2lCheckLoops.doit zelic;
L2lCheckOutputs.doit zelic;
+
+ (* XXX just to see if it compiles *)
+(* let zesoc = Lic2soc.f zelic in *)
+
+(* SocUtils.output true "xxx" zesoc; *)
+
zelic
diff --git a/src/errors.ml b/src/errors.ml
index 3f1ff667..9179d3f8 100644
--- a/src/errors.ml
+++ b/src/errors.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 12/02/2013 (at 18:23) by Erwan Jahier> *)
+(* Time-stamp: <modified the 25/02/2013 (at 17:09) by Erwan Jahier> *)
(** *)
diff --git a/src/lic.ml b/src/lic.ml
index 83516cfb..b8f40451 100644
--- a/src/lic.ml
+++ b/src/lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/02/2013 (at 15:58) by Erwan Jahier> *)
+(* Time-stamp: <modified the 20/02/2013 (at 11:19) by Erwan Jahier> *)
(** Define the Data Structure representing Compiled programs. *)
@@ -163,6 +163,8 @@ and val_exp_core =
(by_name_op srcflagged * (Ident.t srcflagged * val_exp) list)
| Merge of Ident.t srcflagged * (const srcflagged * val_exp) list
+
+
and by_name_op =
| STRUCT of Ident.long
| STRUCT_with of Ident.long * Ident.t (* XXX devrait etre une expression !!! *)
@@ -420,8 +422,7 @@ let ident_of_type = function
| Struct_type_eff (id, _) -> id
| TypeVar Any -> Ident.out_of_pack "any"
| (TypeVar AnyNum) -> Ident.out_of_pack "anynum"
- | _ -> assert false
-
+ | Array_type_eff(_,_) -> assert false
(****************************************************************************)
(* Utilitaires liés aux node_key *)
diff --git a/src/lic2soc.ml b/src/lic2soc.ml
new file mode 100644
index 00000000..8abe38f3
--- /dev/null
+++ b/src/lic2soc.ml
@@ -0,0 +1,628 @@
+(** Time-stamp: <modified the 25/02/2013 (at 18:09) by Erwan Jahier> *)
+
+open Lxm
+open Lic
+
+type action = ActionsDeps.action
+
+(* Raised when a soc that haven't been translated yet is used in
+ another soc during the translation *)
+exception Undef_soc of Lic.node_key
+
+(*********************************************************************************)
+(** Informations liées au contexte de traduction. *)
+type ctx = {
+ prg : LicPrg.t;
+ last_temp_var : int;
+ last_mem : int;
+ locals : Soc.var list;
+}
+
+let create_context: (LicPrg.t -> ctx) =
+ fun prg ->
+ {
+ prg = prg;
+ last_temp_var = 0;
+ last_mem = 0;
+ locals = [];
+ }
+
+let rec lic_to_soc_type: (Lic.type_ -> Soc.var_type) =
+ function
+ | Lic.Bool_type_eff -> Soc.Bool
+ | Lic.Int_type_eff -> Soc.Int
+ | Lic.Real_type_eff -> Soc.Real
+ | Lic.External_type_eff s -> Soc.Extern (Ident.string_of_long s)
+ | Lic.Enum_type_eff (id, l) -> (
+ Soc.Enum(Ident.string_of_long id, List.map Ident.string_of_long l)
+ )
+ | Lic.Struct_type_eff (id, fl) -> (
+ let trans_field (id,(t,_)) = (* fde_value is ignored. Good idea? *)
+ Ident.to_string id, lic_to_soc_type t
+ in
+ let id = Ident.string_of_long id in
+ Soc.Struct(id, List.map trans_field fl)
+ )
+ | Lic.Array_type_eff(ty,i) -> Soc.Array(lic_to_soc_type ty,i)
+ | Lic.Abstract_type_eff (id, _) -> assert false
+ | Lic.TypeVar Lic.Any -> assert false
+ | Lic.TypeVar Lic.AnyNum -> assert false
+
+
+(*********************************************************************************)
+(** Renomme une variable définie par l'utilisateur.
+
+ On veut éviter de créer des variables temporaires portant le même nom que
+ celles définies par l'utilisateur. Donc on renomme simplement celles de
+ l'utilisateur, c'est le plus simple.
+
+XXX obselete ?
+Mieux vaudrait utiliser le meme mechanisme que celui utilisé
+actuellement lors des l2l*.ml
+???
+*)
+let rename_user_var: (string -> string) = fun s ->
+ let prefix = "_" in
+ let suffix = "" in
+ prefix ^ s ^ suffix
+
+let is_predefined_const: string -> Lic.type_ option =
+ function
+ | "true" | "false" -> Some Lic.Bool_type_eff
+ | _ -> None
+
+(*********************************************************************************)
+(* Returns the list of indexes represented by the slice *)
+let (slice_info_to_index_list : Lic.slice_info -> int list) =
+ fun si ->
+ let (f,l,s) = (si.Lic.se_first, si.Lic.se_last, si.Lic.se_step) in
+ let rec aux f =
+ if f>l && s > 0 || f<l && s <0 then [] else
+ f::(aux (f+s))
+ in
+ aux f
+
+let rec get_leaf: (LicPrg.t -> Lic.val_exp -> Soc.var_expr list option) =
+ fun licprg val_exp ->
+ let v = val_exp.Lic.ve_core in
+ let type_ = val_exp.Lic.ve_typ in
+ match v with
+ | Lic.CallByNameLic(by_name_op_flg,fl) -> assert false
+ | Lic.Merge(c_flg, cl) -> assert false
+ | Lic.CallByPosLic (by_pos_op_flg, val_exp_list) -> (
+ match by_pos_op_flg.it with
+ | Lic.PREDEF_CALL _ -> assert false (* todo *)
+ | Lic.VAR_REF name ->
+ let type_ = (List.hd type_) in
+ let translation =
+ match is_predefined_const name with
+ | Some type_ -> Soc.Const(name, lic_to_soc_type type_)
+ | None -> Soc.Var(rename_user_var name, lic_to_soc_type type_)
+ in
+ Some [translation]
+ | Lic.CONST_REF l -> (
+ let type_ = lic_to_soc_type (List.hd type_) in
+ Some [Soc.Const(Ident.string_of_long l, type_)]
+ )
+ | Lic.STRUCT_ACCESS(field) -> (
+ let expr = match val_exp_list with [e] -> e | _ -> assert false in
+ let type_ = lic_to_soc_type (List.hd type_) in
+ let filter_expr = match get_leaf licprg expr with
+ | Some [f] -> f
+ | None -> assert false
+ | _ -> assert false
+ in
+ Some [Soc.Field(filter_expr, field, type_)]
+ )
+ | Lic.ARRAY_ACCES i -> (
+ let expr = match val_exp_list with [e] -> e | _ -> assert false in
+ let type_ = lic_to_soc_type (List.hd type_) in
+ let filter_expr = match get_leaf licprg expr with
+ | Some [f] -> f
+ | None -> assert false (* should not happen, since the expression should be a leaf *)
+ | _ -> assert false (* We should get only ONE filter, otherwise it doesn't make any
+ sense *)
+ in
+ Some [Soc.Index(filter_expr, i, type_)]
+ )
+ | Lic.TUPLE -> (
+ let var_values = List.map (get_leaf licprg) val_exp_list in
+ let del_some = function | None -> assert false | Some x -> x in
+ Some (List.flatten (List.map del_some var_values))
+ )
+ | Lic.ARRAY_SLICE si -> (
+ let id = match val_exp_list with
+ | [{Lic.ve_core=Lic.CallByPosLic({it=Lic.VAR_REF id},[])}] -> id
+ | _ -> assert false
+ in
+ let type_elt_ref,type_ref =
+ match type_ with
+ | [Lic.Array_type_eff(t,i)] ->
+ let t_soc = lic_to_soc_type t in
+ t_soc, Soc.Array(t_soc,i)
+ | _ -> assert false (* should not occur *)
+ in
+ let index_list = slice_info_to_index_list si in
+ let exploded_array =
+ (* val_exp is a var ident (t) of type array; we want to gen the list
+ t[i1], ...,t[in], where the index are specified by the slice
+ *)
+ List.map
+ (fun i -> Soc.Index(Soc.Const(id, type_ref), i, type_elt_ref))
+ index_list
+ in
+ Some(exploded_array)
+ )
+ | Lic.CALL _
+ | Lic.PRE
+ | Lic.ARROW
+ | Lic.FBY
+ | Lic.CURRENT
+ | Lic.WHEN(_)
+ | Lic.CONCAT
+ | Lic.HAT _
+ | Lic.ARRAY
+ -> None
+ )
+(** Traduction d'une partie gauche d'équation en filtre d'accès soc. *)
+let rec filter_of_left_part: (LicPrg.t -> Lic.left -> Soc.var_expr list) =
+ fun licprg lp ->
+ let type_ = Lic.type_of_left lp in
+ match lp with
+ | Lic.LeftVarLic (vi, _lxm) -> (
+ [Soc.Var (rename_user_var vi.Lic.var_name_eff, lic_to_soc_type vi.Lic.var_type_eff)]
+ )
+ | Lic.LeftFieldLic(lp,field,t) -> (
+ let lpl = filter_of_left_part licprg lp in
+ List.map (fun lp -> Soc.Field(lp, field, lic_to_soc_type t)) lpl
+ )
+ | Lic.LeftArrayLic(lp,index,t) -> (
+ let lpl = filter_of_left_part licprg lp in
+ List.map (fun lp -> Soc.Index(lp, index, lic_to_soc_type t (* type_ ? *))) lpl
+ )
+ | Lic.LeftSliceLic(lp,si,t) -> (
+ (* we expand left part slices *)
+ let lpl = filter_of_left_part licprg lp in
+ let index_list = slice_info_to_index_list si in
+ List.flatten (List.map (
+ fun lp -> List.map (fun index -> Soc.Index(lp, index, lic_to_soc_type t)) index_list) lpl)
+ )
+
+(*********************************************************************************)
+let rec (gao_of_action: action -> Soc.gao) =
+ fun (ck, il, ol, op, lxm) ->
+ let rec unpack_clock = function
+ | Lic.BaseLic -> Soc.Call (ol, op, il)
+ | Lic.ClockVar i -> assert false
+ | Lic.On((c, value), inner_clock) ->
+(* let inner_clock = match inner_clock_opt with *)
+(* | Some x -> x *)
+(* | None -> *)
+(* (* TODO? Retreive the clock of c *) *)
+(* Errors.internal lxm; *)
+(* assert false *)
+(* in *)
+ Soc.Case (Ident.string_of_idref c, [value, [unpack_clock inner_clock]] )
+ in
+ unpack_clock ck
+
+(* Construit une méthode à partir des informations données *)
+let build_meth: Lxm.t -> string -> Lic.node_exp -> Soc.var list ->
+ action list -> Soc.step_method =
+ fun lxm name node locals actions ->
+ (* Converti les entrées/sorties d'un noeud en index
+ d'entrées/sorties du composant *)
+ let convert_node_interface = fun l ->
+ fst (List.fold_left (fun (a, i) _ -> a @ [i], i+1) ([], 0) l)
+ in
+ {
+ Soc.socm_name = name;
+ Soc.socm_inputs = convert_node_interface node.Lic.inlist_eff;
+ Soc.socm_outputs = convert_node_interface node.Lic.outlist_eff;
+ Soc.socm_impl =
+ Some (locals, List.map gao_of_action actions)
+ }
+
+let (lic_to_soc_var : Lic.var_info -> Soc.var) =
+ fun vi ->
+ vi.Lic.var_name_eff, lic_to_soc_type vi.Lic.var_type_eff
+
+let component_profile_of_node: Lic.node_exp -> Soc.var list * Soc.var list =
+ fun n ->
+ let inputs = List.map lic_to_soc_var n.Lic.inlist_eff in
+ let outputs = List.map lic_to_soc_var n.Lic.outlist_eff in
+ inputs, outputs
+
+
+let (val_exp_to_filter: LicPrg.t -> Lic.val_exp -> Soc.var_expr) =
+ fun licprg val_exp ->
+ let v = val_exp.Lic.ve_core in
+ let type_ = val_exp.Lic.ve_typ in
+ match v with
+ | CallByNameLic(by_name_op_flg,fl) -> assert false
+ | Merge(c_flg, cl) -> assert false
+ | CallByPosLic (by_pos_op_flg, val_exp_list) -> (
+ match by_pos_op_flg.it with
+ | VAR_REF name ->
+ let type_ = (List.hd type_) in
+ let translation =
+ match is_predefined_const name with
+ | Some type_ -> Soc.Const(name, lic_to_soc_type type_)
+ | None -> Soc.Var(rename_user_var name, lic_to_soc_type type_)
+ in
+ translation
+ | CONST_REF l -> (
+ let type_ = lic_to_soc_type (List.hd type_) in
+ Soc.Const(Ident.string_of_long l, type_)
+ )
+ | STRUCT_ACCESS(field) -> (
+ let expr = match val_exp_list with [e] -> e | _ -> assert false in
+ let type_ = match type_ with [t] -> lic_to_soc_type t | _ -> assert false in
+ let filter_expr = match get_leaf licprg expr with
+ | Some [f] -> f
+ | None -> assert false
+ | _ -> assert false
+ in
+ Soc.Field(filter_expr, field, type_)
+ )
+ | ARRAY_ACCES i -> (
+ let expr = match val_exp_list with [e] -> e | _ -> assert false in
+ let type_ = lic_to_soc_type (List.hd type_) in
+ let filter_expr = match get_leaf licprg expr with
+ | Some [f] -> f
+ | None -> assert false
+ | _ -> assert false
+ in
+ Soc.Index(filter_expr, i, type_)
+ )
+ | PREDEF_CALL _
+ | CALL _
+ | PRE
+ | ARROW
+ | FBY
+ | CURRENT
+ | WHEN(_)
+ | TUPLE
+ | CONCAT
+ | HAT _
+ | ARRAY
+ | ARRAY_SLICE _ ->
+ let lxm = by_pos_op_flg.src in
+ let msg = (Lxm.details lxm) ^
+ ": only one operator per equation is allowed.\n"
+ in
+ raise (Errors.Global_error msg)
+ )
+
+(*********************************************************************************)
+type memory = Soc.memory * action list (* mémoire + initialisation *)
+
+(** Créé une opération à partir d'un nom de méthode d'un composant. *)
+let component_meth_to_operation:
+ Soc.component -> string -> memory option -> Soc.atomic_operation =
+ fun comp func_name -> function
+ | None ->
+ let (node_name,_,_) = comp.Soc.socc_key in
+ Soc.Procedure (node_name ^ "_" ^ func_name)
+ | Some (m, _) -> Soc.Method(m, func_name)
+
+(* Créé une action concernant un appel de procédure ou de méthode. *)
+let (action_of_method: Lxm.t -> Soc.component -> Lic.clock -> Soc.var_expr list ->
+ Soc.var_expr list -> memory option -> Soc.step_method -> action) =
+ fun lxm c clk il ol mem m ->
+ let nth i l =
+ try List.nth l i
+ with _ ->
+ print_string (
+ "\n*** Cannot get the " ^ (string_of_int (i+1)) ^
+ "th element of a list of size " ^ (string_of_int (List.length l))^"\n");
+ flush stdout;
+ assert false
+ in
+ let inputs = List.map (fun i -> nth i il) m.Soc.socm_inputs in
+ let outputs = List.map (fun i -> nth i ol) m.Soc.socm_outputs in
+ let call_action = component_meth_to_operation c m.Soc.socm_name mem in
+ (clk, inputs, outputs, call_action, lxm)
+
+(** Créé un nouveau nom pour une mémoire. *)
+let create_new_memory: (ctx -> ctx * string) = fun ctx ->
+ let prefix = "m" in
+ let suffix = "" in
+ let make id = Format.sprintf "%s%d%s" prefix id suffix in
+ let new_ctx = {ctx with last_mem = ctx.last_mem + 1 } in
+ new_ctx, make new_ctx.last_mem
+
+ (** Créé une nouvelle mémoire pour être utilisée dans un composant.
+
+ Pendant la traduction d'un opérateur, on s'apercoit que cet opérateur
+ dispose d'une mémoire.
+ Il faut donc qu'on créé une mémoire représentant ce composant (issue de la
+ traduction de cet opérateur), afin de garder son état dans le composant
+ résultant de ce noeud. *)
+let create_memory_from_component: (ctx -> Soc.component -> ctx * Soc.memory) =
+ fun ctx c ->
+ let ctx, mem_name = create_new_memory ctx in
+ ctx, Soc.CompMem(mem_name, c.Soc.socc_key)
+
+let (make_memory : Lxm.t -> Lic.clock -> ctx -> Soc.component ->
+ Soc.var_expr list -> Soc.var_expr list -> ctx * memory option) =
+ fun lxm clk ctx component inputs lpl ->
+ match component.Soc.socc_memories with
+ | [] -> ctx, None
+ | _ ->
+ let ctx, m = create_memory_from_component ctx component in
+ let init_actions = match component.Soc.socc_init with
+ | Some i -> [action_of_method lxm component clk inputs lpl (Some (m, [])) i]
+ | None -> assert false
+ (* memory component do have a memory... *)
+ in
+ ctx, Some(m, init_actions)
+
+(*********************************************************************************)
+(** Transforme une expression en action(s), et retourne la liste des variables
+ créées pour stocker le résultat du calcul de cette expression.
+
+ Ces nouvelles variables serviront d'entrées pour l'expression parente.
+*)
+type e2a_acc = ctx * action list * Soc.var_expr list * memory list * ActionsDeps.t
+
+module NkMap = Map.Make(
+ struct
+ type t = Lic.node_key
+ let compare = compare
+ end
+)
+
+
+type comp_tbl = Soc.component NkMap.t
+
+let rec (actions_of_expression_acc: Lxm.t -> comp_tbl ->
+ Lic.clock -> Soc.var_expr list -> e2a_acc -> Lic.val_exp -> e2a_acc) =
+ fun lxm comp_tbl clk lpl acc expr ->
+ let (ctx, al, iol, ml, deps) = acc in
+ match get_leaf ctx.prg expr with
+ | Some names ->
+ (* expr est déjà une feuille (un ident ou une constante), RAF. *)
+ let action = clk, names, lpl, Soc.Assign,lxm in
+ (ctx, action::al, iol@names, ml, deps)
+ | None -> (
+ let v = expr.Lic.ve_core in
+ match v with
+ | CallByNameLic(by_name_op_flg,fl) -> (
+ (* Pas de composant pour les structures non plus. On se
+ contente d'éclater la structure en autant d'égalités
+ que nécessaire. *)
+ let lxm = by_name_op_flg.src in
+ let filter_to_field filter field ftype =
+ let ftype = match ftype with [x] -> x | _ -> assert false in
+ let filter = match filter with [x] -> x | _ -> assert false in
+ Soc.Field(filter, field, lic_to_soc_type ftype)
+ in
+ let actions =
+ List.map
+ (fun (fn, fv) ->
+ let ft = fv.ve_typ in
+ let fv = val_exp_to_filter ctx.prg fv in
+ (clk,
+ [fv],
+ [filter_to_field lpl fn.it ft],
+ Soc.Assign,
+ lxm
+ )
+ )
+ fl
+ in
+ ctx, actions@al, iol, ml, deps
+ )
+ | Merge(c_flg, cl) -> assert false
+ | CallByPosLic (by_pos_op_flg, val_exp_list) -> (
+ match by_pos_op_flg.it with
+ (* handled via get_leaf *)
+ | Lic.ARRAY_SLICE _ | Lic.VAR_REF _ | Lic.CONST_REF _
+ | Lic.ARRAY_ACCES _ | Lic.STRUCT_ACCESS _ | Lic.TUPLE
+ -> assert false
+ | Lic.WHEN ck -> (assert false
+(* (* L'opérateur when n'est pas un composant, il modifie *)
+(* simplement les conditions de traitement des expressions. *) *)
+(* let ctx, actions, inputs, mems, deps = *)
+(* actions_of_expression_list comp_tbl clk lpl acc val_exp_list *)
+(* in *)
+(* let new_clock = *)
+(* match ck with *)
+(* | AstCore.Base -> CE_base *)
+(* | AstCore.NamedClock {it=(cc,cv)} -> *)
+(* CE_clock(name, value, clk) *)
+(* Clocking.clock_eff_of_clock_exp ctx.prg ck *)
+(* in *)
+(* let ctx, outputs, actions_reclocked = *)
+(* match actions with *)
+(* | [] -> *)
+(* (* L'expression du when est une feuille, on créé quand *)
+(* même une nouvelle action pour clocker la feuille. *) *)
+(* ctx, lpl, [new_clock, inputs, lpl, Soc.Assign, lxm] *)
+(* | _ -> *)
+(* ctx, inputs, *)
+(* (* Remplacement de l'horloge des actions de l'expression *)
+(* par la nouvelle horloge issue du `when`. *) *)
+(* List.map *)
+(* (fun (_, i,o,op,lxm) -> new_clock,i,o,op,lxm) *)
+(* actions *)
+(* in *)
+(* ctx, actions_reclocked, outputs, mems, deps *)
+ )
+ | PREDEF_CALL _ | CALL _ | PRE | ARROW | FBY | CURRENT | CONCAT
+ | HAT _ | ARRAY -> (
+ (* build the component of "expr" *)
+ let component : Soc.component =
+ let args_types : Soc.var_type list =
+ List.map lic_to_soc_type
+ (List.flatten (List.map (fun ve -> ve.ve_typ) val_exp_list))
+ in
+ match
+ SocPredef.component_interface_of_pos_op lxm by_pos_op_flg.it args_types
+ with
+ | SocPredef.SC soc -> soc
+ | SocPredef.Undef nk ->
+ try NkMap.find nk comp_tbl
+ with Not_found -> raise (Undef_soc nk)
+ in
+ (* Use that component to build the corresponding
+ - actions
+ - memories
+ - action dependances
+ *)
+ let inputs : Soc.var_expr list =
+ List.map (val_exp_to_filter ctx.prg) val_exp_list in
+ let ctx, mem_opt = make_memory lxm clk ctx component inputs lpl in
+ let actions =
+ let m2act = action_of_method lxm component clk inputs lpl mem_opt in
+ List.map m2act component.Soc.socc_step
+ in
+ let dependances : ActionsDeps.t =
+ let (prefixed_actions : (Soc.ident * action) list) = List.map2
+ (fun s a -> s.Soc.socm_name,a) component.Soc.socc_step actions
+ in
+ ActionsDeps.generate_deps_from_step_policy
+ component.Soc.socc_precedences prefixed_actions
+ in
+ let mem = match mem_opt with Some m -> [m] | None -> [] in
+ (ctx, actions, lpl, mem, dependances)
+ )
+ )
+ )
+
+
+
+
+(** Traduction d'une liste d'expressions. *)
+and (actions_of_expression_list: Lxm.t -> comp_tbl -> Lic.clock -> Soc.var_expr list ->
+ e2a_acc -> Lic.val_exp list -> e2a_acc) =
+ fun lxm comp_tbl clk lpl expr_list acc ->
+ List.fold_left (actions_of_expression_acc lxm comp_tbl clk lpl) expr_list acc
+
+
+let (actions_of_expression : Lxm.t -> comp_tbl -> ctx -> Lic.clock -> Soc.var_expr list ->
+ Lic.val_exp -> e2a_acc) =
+ fun lxm comp_tbl ctx clk lpl expr ->
+ let acc0 = (ctx, [], [], [], ActionsDeps.empty) in
+ actions_of_expression_acc lxm comp_tbl clk lpl acc0 expr
+
+(*********************************************************************************)
+ (** Traduction d'une équation complète.
+
+ On traduit d'abord l'expression de l'équation, puis on fait une égalité
+ entre les variables issues de la traduction de l'expression et la partie
+ gauche de l'équation. *)
+let (actions_of_equation: Lxm.t -> comp_tbl -> ctx -> Lic.eq_info ->
+ ctx * action list * memory list * ActionsDeps.t) =
+ fun lxm comp_tbl ctx (left_part, right_part) ->
+ let clk = right_part.ve_clk in
+ let clk = match clk with [clk] -> clk | _ -> assert false in
+ let left_loc = List.map (filter_of_left_part ctx.prg) left_part in
+ let left_loc = List.flatten left_loc in
+ let ctx, actions, _, memories, deps =
+ actions_of_expression lxm comp_tbl ctx clk left_loc right_part
+ in
+(* let final_action = clk_l, inputs, left_loc, Soc.Identity in *)
+(* let deps = add deps final_action actions in *)
+ ctx, actions, memories, deps
+
+
+
+(*********************************************************************************)
+(** Traduit un noeud en composant Soc. *)
+let rec (component_of_node: LicPrg.t -> Lic.node_exp -> comp_tbl -> ctx * Soc.component) =
+ fun licprg node comp_tbl ->
+ match node.Lic.def_eff with
+ | ExternLic -> assert false
+ | MetaOpLic node_key -> assert false
+ | AbstractLic None -> assert false (* None if extern in the provide part *)
+ | AbstractLic (Some node_exp) -> component_of_node licprg node_exp comp_tbl
+ | BodyLic b ->
+
+ let lxm = node.lxm in
+ let ctx = create_context licprg in
+ let ctx, actions, mems, deps =
+ (* on itere sur la liste des équations *)
+ List.fold_left
+ (fun (c, a, m, d) eq ->
+ let nc, na, nm, nd = actions_of_equation eq.src comp_tbl c eq.it in
+ nc, a @ na, m @ nm, (ActionsDeps.concat nd d)
+ )
+ (ctx, [], [], ActionsDeps.empty)
+ b.eqs_eff
+
+ in
+ (* Construction des dépendances entre les expressions *)
+ let all_deps = ActionsDeps.build_data_deps_from_actions deps actions in
+ let actions =
+ try Toposort.f
+ ActionsDeps.string_of_action_simple actions (ActionsDeps.find_deps all_deps)
+ with Toposort.DependencyCycle(x,l) ->
+ let msg = "A combinational cycle been detected "^
+ (Lxm.details lxm)^": \n "^x^"\n "^(String.concat "\n " l)
+ in
+ raise (Errors.Global_error msg)
+ in
+ let (locals: Soc.var list) =
+ match node.Lic.loclist_eff with
+ | None -> []
+ | Some l -> List.map (lic_to_soc_var) l
+ in
+ let meth = build_meth lxm "step" node (locals @ ctx.locals) actions in
+ let profile = component_profile_of_node node in
+ let memories, init_actions = List.split mems in
+ let init_meth = match init_actions with
+ | [] -> None
+ | actions -> Some (build_meth lxm "init" node [] (List.flatten actions))
+ in
+ let io_list = node.Lic.inlist_eff @ node.Lic.outlist_eff in
+ let io_type = List.map (fun vi -> lic_to_soc_type vi.var_type_eff) io_list in
+ let comp = {
+ Soc.socc_key = fst (fst node.Lic.node_key_eff), io_type, None;
+ Soc.socc_profile = profile;
+ Soc.socc_memories = memories;
+ Soc.socc_init = init_meth;
+ Soc.socc_step = [meth];
+ Soc.socc_precedences = []; (* TODO pour l'instant, on ne gère qu'une
+ seule méthode *)
+ }
+ in
+ ctx, comp
+
+
+(*********************************************************************************)
+open Soc
+
+(* exported *)
+let f: (LicPrg.t -> Soc.component list) =
+ fun prog ->
+ let rec (process_node:Lic.node_key -> Lic.node_exp -> comp_tbl -> comp_tbl) =
+ fun nk node acc_comp ->
+ let name = (* Lic.string_of_node_key *) nk in
+ if NkMap.mem name acc_comp then acc_comp else
+ (match SocPredef.of_node_key name with
+ | SocPredef.SC soc -> NkMap.add name soc acc_comp
+ | SocPredef.Undef nk ->
+ try
+ (match LicPrg.find_node prog nk with
+ | None -> assert false
+ | Some node_def ->
+ let _, soc = component_of_node prog node_def acc_comp in
+ NkMap.add name soc acc_comp
+ )
+ with
+ | Undef_soc n_ukn ->
+ (* Il manque une dépendance, on essaie de
+ la traduire puis de retraduire le noeud courant. *)
+ (match LicPrg.find_node prog n_ukn with
+ | None -> assert false
+ | Some node_ukn ->
+ let comps = process_node n_ukn node_ukn acc_comp in
+ process_node name node comps
+ )
+ )
+ in
+ let soc_string_map = LicPrg.fold_nodes process_node prog NkMap.empty in
+ let soc_list = NkMap.fold (fun n soc acc -> soc::acc) soc_string_map [] in
+ soc_list
diff --git a/src/lic2soc.mli b/src/lic2soc.mli
new file mode 100644
index 00000000..6f43c3fa
--- /dev/null
+++ b/src/lic2soc.mli
@@ -0,0 +1,3 @@
+(** Time-stamp: <modified the 20/02/2013 (at 10:50) by Erwan Jahier> *)
+
+val f: LicPrg.t -> Soc.component list
diff --git a/src/soc.ml b/src/soc.ml
new file mode 100644
index 00000000..491cbdb6
--- /dev/null
+++ b/src/soc.ml
@@ -0,0 +1,64 @@
+(** Synchronous Object Component *)
+
+(* Just a string because :
+ - it's more ocamldebug-friendly
+ - Name clashing issues ougth to have been fixed before
+ *)
+type ident = string
+
+type var_type =
+ | Bool | Int | Real
+ | Extern of ident
+ | Enum of (ident * ident list)
+ | Struct of ident * (ident * var_type) list
+ | Array of (var_type * int)
+ | Alpha of int
+
+type var = ident * var_type
+
+type component_key =
+ ident *
+ var_type list * (* I/O type list *)
+ (int * int * int) option (* to deal with slices (useful?) *)
+
+type memory =
+ | CompMem of ident * component_key (* Memory name * instanciated component key *)
+ | VarMem of var
+
+(* Variable denotation *)
+type var_expr =
+ | Var of ident * var_type
+ | Const of ident * var_type (* useful? *)
+ | Field of var_expr * ident * var_type
+ | Index of var_expr * int * var_type
+
+type atomic_operation =
+ | Assign (* Wire *)
+ | Method of memory * ident (* step call *)
+ | Procedure of ident (* memoryless method made explicit *)
+
+(* Guarded Atomic Operation *)
+type gao =
+ | Case of ident * (ident * gao list) list
+ | Call of var_expr list * atomic_operation * var_expr list
+ (* outputs * op * inputs *)
+
+type step_method = {
+ socm_name : ident;
+ socm_inputs : int list;
+ socm_outputs : int list;
+ socm_impl : (var list * gao list) option; (* local vars + body *)
+}
+
+type precedence = ident * ident list
+(* maps a step method name with the list of step methods that should
+ be called _before_ in the current step *)
+
+type component = {
+ socc_key : component_key;
+ socc_profile : var list * var list;
+ socc_memories : memory list;
+ socc_init : step_method option;
+ socc_step : step_method list;
+ socc_precedences : precedence list;
+}
diff --git a/src/socPredef.ml b/src/socPredef.ml
new file mode 100644
index 00000000..9ed70a02
--- /dev/null
+++ b/src/socPredef.ml
@@ -0,0 +1,523 @@
+(* Time-stamp: <modified the 21/02/2013 (at 11:10) by Erwan Jahier> *)
+
+(** Synchronous Object Code for Predefined operators. *)
+
+let finish_me lxm
+ = print_string ("\nsocPref.ml:"^(Lxm.details lxm)^" -> finish me!\n")
+
+
+open Soc
+
+(* Some aliases *)
+let b = Soc.Bool
+let i = Soc.Int
+let r = Soc.Real
+let alpha = Soc.Alpha 0
+
+let bb = ["x", b], ["z", b]
+let ii = ["x", i], ["z", i]
+let rr = ["x", r], ["z", r]
+let ri = ["r", r], ["i", i]
+let ir = ["i", i], ["r", r ]
+let aa = ["x", alpha], ["z", alpha]
+
+let bbb = ["x", b; "y", b], ["z", b]
+let iii = ["x", i; "y", i], ["z", i]
+let rrr = ["x", r; "y", r], ["z", r]
+let rrb = ["x", r; "y", r], ["z", b]
+let iib = ["x", i; "y", i], ["z", b]
+let aaa = ["i", alpha; "x", alpha], ["z", alpha]
+
+
+let step11 = { (* a useful alias again *)
+ socm_name = "step";
+ socm_inputs = [0];
+ socm_outputs = [0];
+ socm_impl = None;
+}
+let step21 = { (* a useful alias again *)
+ socm_name = "step";
+ socm_inputs = [0;1];
+ socm_outputs = [0];
+ socm_impl = None;
+}
+
+(* used to build predef soc with no memory *)
+let make_soc key profile steps = {
+ socc_key = key;
+ socc_profile = profile;
+ socc_memories = [];
+ socc_init = None;
+ socc_precedences = [];
+ socc_step = steps;
+ }
+
+
+type soc_comp_opt = SC of Soc.component | Undef of Lic.node_key
+
+(* exported *)
+let of_node_key : Lic.node_key -> soc_comp_opt =
+ fun nk ->
+ match fst nk with
+ | "Lustre","mod" -> SC (make_soc ("mod", [], None) ii [step11])
+ | "Lustre","iuminus" -> SC (make_soc ("iuminus", [], None) ii [step11])
+ | "Lustre","ruminus" -> SC (make_soc ("ruminus", [], None) rr [step11])
+ | "Lustre","not" -> SC (make_soc ("not", [], None) bb [step11])
+ | "Lustre","real2int" -> SC (make_soc ("real2int", [], None) ri [step11])
+ | "Lustre","int2real" -> SC (make_soc ("int2real", [], None) ir [step11])
+
+ | "Lustre","iplus" -> SC (make_soc ("iplus", [], None) iii [step21])
+ | "Lustre","rplus" -> SC (make_soc ("rplus", [], None) rrr [step21])
+ | "Lustre","itimes" -> SC (make_soc ("itimes", [], None) iii [step21])
+ | "Lustre","rtimes" -> SC (make_soc ("rtimes", [], None) rrr [step21])
+ | "Lustre","idiv" -> SC (make_soc ("idiv", [], None) iii [step21])
+ | "Lustre","rdiv" -> SC (make_soc ("rdiv", [], None) rrr [step21])
+ | "Lustre","iminus" -> SC (make_soc ("iminus", [], None) iii [step21])
+ | "Lustre","rminus" -> SC (make_soc ("rminus", [], None) rrr [step21])
+
+ | "Lustre","ilt" -> SC (make_soc ("ilt", [], None) iib [step21])
+ | "Lustre","rlt" -> SC (make_soc ("rlt", [], None) rrb [step21])
+ | "Lustre","igt" -> SC (make_soc ("igt", [], None) iib [step21])
+ | "Lustre","rgt" -> SC (make_soc ("rgt", [], None) rrb [step21])
+ | "Lustre","ilte" -> SC (make_soc ("ilte", [], None) iib [step21])
+ | "Lustre","rlte" -> SC (make_soc ("rlte", [], None) rrb [step21])
+ | "Lustre","igte" -> SC (make_soc ("igte", [], None) iib [step21])
+ | "Lustre","rgte" -> SC (make_soc ("rgte", [], None) rrb [step21])
+
+ | "Lustre","and" -> SC (make_soc ("and", [], None) bbb [step21])
+ | "Lustre","beq" -> SC (make_soc ("beq", [], None) bbb [step21])
+ | "Lustre","ieq" -> SC (make_soc ("ieq", [], None) iib [step21])
+ | "Lustre","req" -> SC (make_soc ("req", [], None) rrb [step21])
+ | "Lustre","neq" -> SC (make_soc ("neq", [], None) bbb [step21])
+ | "Lustre","or" -> SC (make_soc ("or", [], None) bbb [step21])
+ | "Lustre","xor" -> SC (make_soc ("xor", [], None) bbb [step21])
+ | "Lustre","impl" -> SC (make_soc ("impl", [], None) bbb [step21])
+
+ | "Lustre","current" -> SC (make_soc ("current", [alpha], None) aa [step11])
+
+ | "Lustre","fby" -> SC {
+ socc_key = "fby", [alpha], None;
+ socc_profile = aaa;
+ socc_memories = [VarMem("m", alpha)];
+ socc_step = [
+ {
+ socm_name = "get";
+ socm_inputs = [];
+ socm_outputs = [0];
+ socm_impl = None;
+ };
+ {
+ socm_name = "set";
+ socm_inputs = [1];
+ socm_outputs = [];
+ socm_impl = None
+ };
+ ];
+ socc_precedences = ["set", ["get"]];
+ socc_init = Some {
+ socm_name = "init";
+ socm_inputs = [0] ;
+ socm_outputs = [];
+ socm_impl = None;
+ };
+ }
+
+ | "Lustre","pre" -> SC {
+ socc_key = "pre", [alpha], None;
+ socc_profile = aa;
+ socc_memories = [VarMem("m", alpha)];
+ socc_step = [
+ {
+ socm_name = "get";
+ socm_inputs = [];
+ socm_outputs = [0];
+ socm_impl = None;
+ };
+ {
+ socm_name = "set";
+ socm_inputs = [0];
+ socm_outputs = [];
+ socm_impl = None
+ };
+ ];
+ socc_precedences = ["set", ["get"]];
+ socc_init = Some {
+ socm_name = "init";
+ socm_inputs = [] ; (* XXX ??? *)
+ socm_outputs = [];
+ socm_impl = None;
+ };
+ }
+ | "Lustre","arrow" -> SC {
+ socc_key = "arrow", [alpha], None;
+ socc_profile = aaa;
+ socc_memories = [];
+ socc_step = [
+ {
+ socm_name = "step";
+ socm_inputs = [1];
+ socm_outputs = [0];
+ socm_impl = None;
+ };
+ ];
+ socc_precedences = [];
+ socc_init = Some {
+ socm_name = "init";
+ socm_inputs = [0];
+ socm_outputs = [];
+ socm_impl = None;
+ };
+ }
+
+ | "Lustre","if" -> SC {
+ socc_key = "if", [alpha], None;
+ socc_profile = (
+ ["c", b ; "x", alpha; "y", alpha],
+ ["z", alpha]
+ );
+ socc_memories = [];
+ socc_init = None;
+ socc_precedences = [];
+ socc_step = [
+ {
+ socm_name = "step";
+ socm_inputs = [0; 1; 2];
+ socm_outputs = [0];
+ socm_impl = None;
+ }
+ ];
+ }
+ | _ -> Undef nk
+
+
+(** Instancie un composant polymorphe avec un type concret. *)
+let instanciate_component: component -> Soc.var_type -> component =
+ fun c concrete_type ->
+ let new_profile =
+ List.map (fun (n, i) -> n, concrete_type) (fst c.socc_profile),
+ List.map (fun (n, i) -> n, concrete_type) (snd c.socc_profile)
+ in
+ let (key1, key2, key3) = c.socc_key in
+ let new_key = (key1, List.map (fun _ -> concrete_type) key2, key3) in
+ let new_memories =
+ List.map
+ (function | VarMem(n, t) -> VarMem(n, concrete_type) | _ -> assert false)
+ c.socc_memories
+ in
+ {
+ c with
+ socc_key = new_key;
+ socc_profile = new_profile;
+ socc_memories = new_memories;
+ }
+
+
+(*
+ XXX Faut-il definir une version générique des composants tranches ?
+
+ Je les ai défini directement via "make_slice_component", ce qui
+ n'est pas homogene avec la facon dont sont traités les autres
+ composants génériques style 'fby'.
+
+ Le truc, c'est que je ne sais pas trop quoi mettre dans la version
+ générique, et comme celle-ci est destinée à être instanciée... En
+ effet, le type de sortie des composants tranche depend de la
+ slice_info passé en parametre lors de l'instanciation des composant
+ génériques. Je pourrais mettre un type alpha, mais je trouve ca
+ idiot, alors je ne le fais pas...
+
+ Une autre solution pour rendre ce traitement homogene serait de ne
+ pas passer par une version générique pour les composants fby et
+ consort. A voir.
+
+ idem pour "x^n" (Hat_n).
+*)
+
+let make_slice_component: Lic.slice_info -> Soc.var_type -> component =
+ fun si t ->
+ let (f,l,step) = (si.Lic.se_first, si.Lic.se_last,si.Lic.se_step) in
+ let sub_array_type =
+ match t with
+ | Soc.Array(t_elt,size) ->
+ let slice_size = 1+abs( (l - f) / step) in
+ Soc.Array(t_elt, slice_size)
+ | _ -> assert false
+ in
+ {
+ socc_key = ("array_slice", [t], Some (f, l, step));
+ socc_profile = (["t", t], ["st", sub_array_type ]);
+ socc_memories = [];
+ socc_step = [
+ {
+ socm_name = "step";
+ socm_inputs = [0];
+ socm_outputs = [0];
+ socm_impl = None;
+ };
+ ];
+ socc_precedences = [];
+ socc_init = None;
+ }
+
+
+let make_array_component: int -> Soc.var_type -> component =
+ fun i t ->
+ let array_type =
+ match t with
+ | Soc.Alpha _ -> assert false
+ | t -> Soc.Array(t,i)
+ in
+ {
+ socc_key = ("hat", [array_type], None);
+ socc_profile = (["t", t], ["st", array_type]);
+ socc_memories = [];
+ socc_step = [
+ {
+ socm_name = "step";
+ socm_inputs = [0];
+ socm_outputs = [0];
+ socm_impl = None;
+ };
+ ];
+ socc_precedences = [];
+ socc_init = None;
+ }
+
+
+
+let component_interface_of_predef:
+ Lxm.t -> AstPredef.op -> Soc.var_type list -> soc_comp_opt =
+ fun lxm op types ->
+ match (op, types) with
+ | AstPredef.IPLUS_n, [Int; Int] -> of_node_key (("Lustre","iplus"), [])
+ | AstPredef.PLUS_n, [Int; Int] -> of_node_key (("Lustre","iplus"), [])
+ | AstPredef.PLUS_n, [Real; Real] -> of_node_key (("Lustre","rplus"), [])
+ | AstPredef.RPLUS_n, [Real; Real] -> of_node_key (("Lustre","rplus"), [])
+ | AstPredef.ITIMES_n,[Int; Int] -> of_node_key (("Lustre","itimes"), [])
+ | AstPredef.TIMES_n, [Int; Int] -> of_node_key (("Lustre","itimes"), [])
+ | AstPredef.TIMES_n, [Real; Real] -> of_node_key (("Lustre","rtimes"), [])
+ | AstPredef.RTIMES_n,[Real; Real] -> of_node_key (("Lustre","rtimes"), [])
+ | AstPredef.ISLASH_n,[Int; Int] -> of_node_key (("Lustre","idiv"), [])
+ | AstPredef.SLASH_n, [Int; Int] -> of_node_key (("Lustre","idiv"), [])
+ | AstPredef.DIV_n, [Int; Int] -> of_node_key (("Lustre","idiv"), [])
+ | AstPredef.MOD_n, [Int;Int] -> of_node_key (("Lustre","mod"), [])
+ | AstPredef.SLASH_n, [Real; Real] -> of_node_key (("Lustre","rdiv"), [])
+ | AstPredef.RSLASH_n,[Real; Real] -> of_node_key (("Lustre","rdiv"), [])
+ | AstPredef.MINUS_n, [Int; Int] -> of_node_key (("Lustre","iminus"), [])
+ | AstPredef.IMINUS_n,[Int; Int] -> of_node_key (("Lustre","iminus"), [])
+ | AstPredef.MINUS_n, [Real; Real] -> of_node_key (("Lustre","rminus"), [])
+ | AstPredef.RMINUS_n,[Real; Real] -> of_node_key (("Lustre","rminus"), [])
+ | AstPredef.UMINUS_n,[Int] -> of_node_key (("Lustre","iuminus"), [])
+ | AstPredef.IUMINUS_n, [Int] -> of_node_key (("Lustre","iuminus"), [])
+ | AstPredef.UMINUS_n, [Real] -> of_node_key (("Lustre","ruminus"), [])
+ | AstPredef.RUMINUS_n, [Real] -> of_node_key (("Lustre","ruminus"), [])
+ | AstPredef.LT_n, [Int; Int] -> of_node_key (("Lustre","ilt"), [])
+ | AstPredef.LT_n, [Real; Real] -> of_node_key (("Lustre","rlt"), [])
+ | AstPredef.GT_n, [Int; Int] -> of_node_key (("Lustre","igt"), [])
+ | AstPredef.GT_n, [Real; Real] -> of_node_key (("Lustre","rgt"), [])
+ | AstPredef.LTE_n, [Int; Int] -> of_node_key (("Lustre","ilte"), [])
+ | AstPredef.LTE_n, [Real; Real] -> of_node_key (("Lustre","rlte"), [])
+ | AstPredef.GTE_n, [Int; Int] -> of_node_key (("Lustre","igte"), [])
+ | AstPredef.GTE_n, [Real; Real] -> of_node_key (("Lustre","rgte"), [])
+ | AstPredef.AND_n, [Bool; Bool] -> of_node_key (("Lustre","and"), [])
+ | AstPredef.OR_n, [Bool; Bool] -> of_node_key (("Lustre","or"), [])
+ | AstPredef.XOR_n, [Bool; Bool] -> of_node_key (("Lustre","xor"), [])
+ | AstPredef.IMPL_n, [Bool; Bool] -> of_node_key (("Lustre","impl"), [])
+ | AstPredef.EQ_n, [Bool; Bool] -> of_node_key (("Lustre","beq"), [])
+ | AstPredef.EQ_n, [Int; Int] -> of_node_key (("Lustre","ieq"), [])
+ | AstPredef.EQ_n, [Real; Real] -> of_node_key (("Lustre","req"), [])
+ | AstPredef.NEQ_n, [Bool; Bool] -> of_node_key (("Lustre","neq"), [])
+ | AstPredef.NOT_n, [Bool] -> of_node_key (("Lustre","not"), [])
+
+ | AstPredef.TRUE_n, [] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.FALSE_n, [] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.RCONST_n _, [] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.ICONST_n _, [] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.REAL2INT_n, [Real] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.INT2REAL_n, [Int] -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.NOR_n, _ -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.DIESE_n, _ -> finish_me lxm ; assert false (* todo *)
+ | AstPredef.IF_n, _ ->
+ let concrete_type = List.nth types 0 in
+ (match of_node_key (("Lustre","if"), []) with
+ | SC comp -> SC(instanciate_component comp concrete_type)
+ | Undef _ -> assert false
+ )
+
+ (* « incorrect lic » *)
+ | AstPredef.IUMINUS_n, _ -> assert false
+ | AstPredef.IMINUS_n, _ -> assert false
+ | AstPredef.RUMINUS_n, _ -> assert false
+ | AstPredef.RMINUS_n, _ -> assert false
+ | AstPredef.TRUE_n, _ -> assert false
+ | AstPredef.FALSE_n, _ -> assert false
+ | AstPredef.RCONST_n _, _ -> assert false
+ | AstPredef.ICONST_n _, _ -> assert false
+ | AstPredef.REAL2INT_n, _ -> assert false
+ | AstPredef.INT2REAL_n, _ -> assert false
+ | AstPredef.PLUS_n, _ -> assert false
+ | AstPredef.IPLUS_n, _ -> assert false
+ | AstPredef.RPLUS_n, _ -> assert false
+ | AstPredef.TIMES_n, _ -> assert false
+ | AstPredef.ITIMES_n, _ -> assert false
+ | AstPredef.RTIMES_n, _ -> assert false
+ | AstPredef.DIV_n, _ -> assert false
+ | AstPredef.MOD_n, _ -> assert false
+ | AstPredef.SLASH_n, _ -> assert false
+ | AstPredef.ISLASH_n, _ -> assert false
+ | AstPredef.RSLASH_n, _ -> assert false
+ | AstPredef.MINUS_n, _ -> assert false
+ | AstPredef.UMINUS_n, _ -> assert false
+ | AstPredef.GT_n, _ -> assert false
+ | AstPredef.LT_n, _ -> assert false
+ | AstPredef.LTE_n, _ -> assert false
+ | AstPredef.GTE_n, _ -> assert false
+ | AstPredef.AND_n, _ -> assert false
+ | AstPredef.OR_n, _ -> assert false
+ | AstPredef.XOR_n, _ -> assert false
+ | AstPredef.IMPL_n, _ -> assert false
+ | AstPredef.EQ_n, _ -> assert false
+ | AstPredef.NEQ_n, _ -> assert false
+ | AstPredef.NOT_n, _ -> assert false
+
+
+let (component_interface_of_pos_op:
+ Lxm.t -> Lic.by_pos_op -> Soc.var_type list -> soc_comp_opt) =
+ fun lxm op types ->
+ match (op, types) with
+ | Lic.PREDEF_CALL op, _ -> component_interface_of_predef lxm op types
+
+ | Lic.CALL op, _ -> assert false (* XXX todo *)
+
+ | Lic.FBY, _ ->
+ let concrete_type = List.nth types 0 in
+ (match of_node_key (("Lustre","fby"), []) with
+ | SC comp -> SC(instanciate_component comp concrete_type)
+ | Undef _ -> assert false
+ )
+ | Lic.PRE, _ ->
+ let concrete_type = List.nth types 0 in
+ (match of_node_key (("Lustre","pre"), []) with
+ | SC comp -> SC(instanciate_component comp concrete_type)
+ | Undef _ -> assert false
+ )
+ | Lic.CURRENT, _ ->
+ let concrete_type = List.nth types 0 in
+ (match of_node_key (("Lustre","current"), []) with
+ | SC comp -> SC(instanciate_component comp concrete_type)
+ | Undef _ -> assert false
+ )
+ | Lic.ARROW, _ ->
+ let concrete_type = List.nth types 0 in
+ (match of_node_key (("Lustre","arrow"), []) with
+ | SC comp -> SC(instanciate_component comp concrete_type)
+ | Undef _ -> assert false
+ )
+ | Lic.HAT i,_ ->
+ let elt_type = List.nth types 0 in
+ SC(make_array_component i elt_type)
+
+ | Lic.ARRAY, _-> finish_me lxm ; assert false
+ | Lic.CONCAT ,_-> finish_me lxm ; assert false
+
+ (* Those are not components *)
+ | Lic.ARRAY_SLICE sinfo,_ -> assert false
+
+ | Lic.VAR_REF _, _ -> assert false
+ | Lic.CONST_REF _, _ -> assert false
+ | Lic.STRUCT_ACCESS _, _ -> assert false
+ | Lic.WHEN _, _ -> assert false
+ | Lic.TUPLE, _ -> assert false
+ | Lic.ARRAY_ACCES _, _ -> assert false
+
+
+(*
+21/02/2013 : ai-je vraiment besoin de ca maintenant que les metaop ont été encapsulé
+dans des noeuds ? bon, je garde quelque temps en commentaire au cas ou...
+ | Lic.Fill(node,size), _
+ | Lic.FillRed(node,size), _
+ | Lic.Red(node,size), _ ->
+ (match of_node_key node with
+ | Undef name -> Undef name
+ (* Given
+ - a node n of type
+ tau * tau_1 * ... * tau_n -> tau * teta_1 * ... * teta_l
+ - a integer c
+
+ the red expression has the profile:
+ tau * tau_1^c * ... * tau_n^c -> tau * teta_1^c * ... * teta_l^c
+ *)
+ | SC c ->
+ let arrayse l =
+ let exp (id,t) =
+ match t with
+ | Soc.Alpha _ -> assert false
+ | t -> id, Soc.Array(t,size)
+ in
+ match l with
+ | [] -> assert false
+ | (id,t)::tail ->(id, t):: (List.map exp tail)
+ in
+ SC {
+ (* XXX la clef devrait contenir le node et la taille ?
+
+ Les composants iterateurs ne meritent ils pas un traitement
+ specifique ?
+ Ce que je veux, c'est
+ - y mettre toute l'information necessaire pour pouvoir generer
+ la boucle for qui va bien,
+ - garder une forme synthetique qui permette de faire des
+ analyses et de la vérification
+
+ *)
+ socc_key = ("fillred" ^ node ^ (string_of_int size), [], None);
+ socc_profile =
+ (arrayse (fst c.socc_profile), arrayse (snd c.socc_profile));
+ socc_memories = c.socc_memories;
+ socc_step = c.socc_step;
+ (* XXX non ! le probleme, c'est que cette methode step
+ doit être fabriquée à partir de la methode step
+ du noeud itéré, et que je n'ai rien pour exprimer
+ ce genre de truc pour l'instant.
+ *)
+ socc_precedences = [];
+ socc_init = c.socc_init; (* XXX non ! *)
+ }
+ )
+ | Lic.Map(node,size), _ ->
+ (match of_node_key node with
+ | Undef name -> Undef name
+ | SC c ->
+ (* Given
+ - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+ - an integer c
+
+ The profile of map is:
+ tau_1^c * ... * tau_n^c -> teta_1^c * ... * teta_l^c
+ *)
+ let arrayse l =
+ let exp (id,t) =
+ match t with
+ | Soc.Alpha _ -> assert false
+ | t -> id, Soc.Array(t,size)
+ in
+ (List.map exp l)
+ in
+ SC {
+ socc_key = ("map" ^ node ^ (string_of_int size), [], None);
+ socc_profile =
+ (arrayse (fst c.socc_profile), arrayse (snd c.socc_profile));
+ socc_memories = c.socc_memories;
+ socc_step = c.socc_step; (* XXX non ! *)
+ socc_precedences = [];
+ socc_init = c.socc_init;
+ }
+ )
+ | Lic.BoolRed(i,j,k), _ -> Errors.finish_me lxm ; assert false
+
+ (* Cas particulier du boolred *)
+ | Lic.DIESE, _-> Errors.finish_me lxm ; assert false
+ | Lic.NOR ,_-> Errors.finish_me lxm ; assert false
+
+
+ *)
diff --git a/src/socPredef.mli b/src/socPredef.mli
new file mode 100644
index 00000000..0e8b5f64
--- /dev/null
+++ b/src/socPredef.mli
@@ -0,0 +1,19 @@
+(* Time-stamp: <modified the 21/02/2013 (at 10:19) by Erwan Jahier> *)
+
+(** Synchronous Object Code for Predefined operators. *)
+
+type soc_comp_opt = SC of Soc.component | Undef of Lic.node_key
+
+val of_node_key : Lic.node_key -> soc_comp_opt
+
+(** Associe un opérateur Lustre et le type de ses opérandes à un SOC
+ et sa fonction de typage.
+
+ Le type des opérandes permet de traiter les opérateurs surchargés.
+*)
+
+val component_interface_of_pos_op:
+ Lxm.t -> Lic.by_pos_op -> Soc.var_type list -> soc_comp_opt
+
+
+
diff --git a/src/socUtils.ml b/src/socUtils.ml
new file mode 100644
index 00000000..ccc34154
--- /dev/null
+++ b/src/socUtils.ml
@@ -0,0 +1,361 @@
+(** Time-stamp: <modified the 30/06/2009 (at 11:45) by Erwan Jahier> *)
+
+
+open Soc
+
+
+(** Donne toute les méthodes d'un composant.
+
+ C'est la liste des méthodes du composant, et la méthode d'initialisation le
+ cas échéant. *)
+let get_all_methods: component -> step_method list = fun c ->
+ match c.socc_init with
+ | None -> c.socc_step
+ | Some m -> m :: c.socc_step
+
+(** Fonctions de représentation des objets LOC. *)
+
+(** Aliases *)
+let str_ff = Format.str_formatter
+let flush_str_ff = Format.flush_str_formatter
+let fprintf = Format.fprintf
+
+(** Encapsule l'appel à une fonction avec formatter pour sortir une string. *)
+let call_fun_ff: ((Format.formatter -> unit) -> string) = fun f ->
+ let b = Buffer.create 50 in
+ let ff = Format.formatter_of_buffer b in
+ f ff;
+ Format.pp_print_flush ff ();
+ let s = Buffer.contents b in
+ Buffer.reset b;
+ s
+
+(* Type *)
+let rec string_of_type_ref_ff: (Soc.var_type -> Format.formatter -> unit) = fun v ff ->
+ let str =
+ match v with
+ | Soc.Bool -> "bool"
+ | Soc.Int -> "int"
+ | Soc.Real-> "real"
+ | Soc.Extern s -> s ^ "(*extern*)"
+ | Soc.Enum (s, sl) -> "enum " ^ s ^ " {" ^ (String.concat ", " sl) ^ "}"
+ | Soc.Struct (sid,_) -> sid ^ "(*struct*)"
+ | Soc.Array (ty, sz) -> Printf.sprintf "%s^%d" (string_of_type_ref ty) sz
+ | Soc.Alpha nb ->
+ (* On génère des "types" à la Caml : 'a, 'b, 'c, etc. *)
+ let a_value = Char.code('a') in
+ let z_value = Char.code('z') in
+ let str =
+ if (nb >= 0 && nb <= (z_value - a_value)) then
+ ("'" ^ (Char.escaped (Char.chr(a_value + nb))))
+ else
+ ("'a" ^ (string_of_int nb))
+ in
+ str
+ in
+ fprintf ff "%s" str
+
+and string_of_type_ref: (Soc.var_type -> string) = fun v ->
+ call_fun_ff (string_of_type_ref_ff v)
+
+
+(* Clé de composant *)
+let string_of_component_key_ff: (Soc.component_key -> Format.formatter -> unit) =
+ fun (id, types, si_opt) ff ->
+ (match types with
+ | [] -> fprintf ff "%s" id
+ | _ -> fprintf ff "(%s)%s"
+ (String.concat " * " (List.map string_of_type_ref types)) id);
+ (match si_opt with
+ | None -> ()
+ | Some(f,l,step) -> fprintf ff "[%d .. %d step %d]" f l step)
+
+let string_of_component_key: (Soc.component_key -> string) = fun v ->
+ call_fun_ff (string_of_component_key_ff v)
+
+
+(* Variable *)
+let string_of_var_ff: (Soc.var -> Format.formatter -> unit) = fun (id, type_) ff ->
+ fprintf ff "%s: %s" id (string_of_type_ref type_)
+
+let string_of_var: (Soc.var -> string) = fun v ->
+ call_fun_ff (string_of_var_ff v)
+
+
+(* Mémoire *)
+let string_of_memory_ff: (memory -> Format.formatter -> unit) = fun v ff ->
+ let name = match v with
+ | CompMem(id, _) -> id
+ | VarMem v -> string_of_var v
+ in
+ fprintf ff "%s" name
+
+let string_of_memory: (memory -> string) = fun v ->
+ call_fun_ff (string_of_memory_ff v)
+
+(* Déclaration d'une mémoire *)
+let string_of_memory_decl_ff: (memory -> Format.formatter -> unit) = fun v ff -> match v with
+ | CompMem(id, key) -> fprintf ff "%s : %s" id (string_of_component_key key)
+ | VarMem v -> fprintf ff "%s" (string_of_var v)
+
+let string_of_memory_decl: (memory -> string) = fun v ->
+ call_fun_ff (string_of_memory_decl_ff v)
+
+
+(* Opération *)
+let string_of_operation_ff: (atomic_operation -> Format.formatter -> unit) = fun v ff -> match v with
+ | Assign -> () (* On suppose qu'il est déjà affiché dans string_of_gao *)
+ | Method(obj, meth) -> fprintf ff "%s.%s" (string_of_memory obj) meth
+ | Procedure proc -> fprintf ff "%s" proc
+
+let string_of_operation: (atomic_operation -> string) = fun v ->
+ call_fun_ff (string_of_operation_ff v)
+
+
+(* Filtre d'accès *)
+let rec string_of_filter_ff: (Soc.var_expr -> Format.formatter -> unit) =
+ fun v ff -> match v with
+ | Const(id, _)
+ | Var (id,_) -> fprintf ff "%s" id
+ | Field(f, id,_) -> string_of_filter_ff f ff; fprintf ff ".%s" id
+ | Index(f, index,_) -> string_of_filter_ff f ff; fprintf ff "[%d]" index
+
+let string_of_filter: (Soc.var_expr -> string) = fun v ->
+ call_fun_ff (string_of_filter_ff v)
+
+(* Code *)
+let rec string_of_gao_ff: (gao -> Format.formatter -> unit) = fun v ff -> match v with
+ | Case (ck, cases) ->
+ let string_of_case: (ident * gao list -> unit) = fun (id, c) ->
+ fprintf ff "@[case %s:@[" id;
+ string_of_gaos_list_ff c ff;
+ fprintf ff "@]@]"
+ in
+ fprintf ff "switch(%s) {" ck;
+ List.iter string_of_case cases;
+ fprintf ff "}"
+
+ | Call(dests, op, srcs) ->
+ let _ =
+ match dests with
+ | [] -> () (* pas de destinations, on affiche pas de "=" *)
+ | _ ->
+ let dests = String.concat ", " (List.map string_of_filter dests) in
+ fprintf ff "%s = " dests
+ in
+ let srcs = String.concat ", " (List.map string_of_filter srcs) in
+ string_of_operation_ff op ff;
+ fprintf ff "(%s)" srcs;
+
+and string_of_gaos_list_ff: (gao list -> Format.formatter -> unit) = fun gaos ff ->
+ List.iter (
+ fun c ->
+ fprintf ff "@[";
+ string_of_gao_ff c ff;
+ fprintf ff ";@]@,"
+ ) gaos
+
+let string_of_gao: (gao -> string) = fun v ->
+ call_fun_ff (string_of_gao_ff v)
+
+let string_of_gaos_list: (gao list -> string) = fun v ->
+ call_fun_ff (string_of_gaos_list_ff v)
+
+
+(* Profil de méthode *)
+let string_interface_of_method_ff: (component -> step_method -> Format.formatter -> unit) = fun c m ff ->
+ let string_var_from_index: (Soc.var list -> int -> string) = fun vl i ->
+ string_of_var (List.nth vl i)
+ in
+ fprintf ff "%s(%s) -> (%s)"
+ m.socm_name
+ (String.concat "; " (List.map (string_var_from_index (fst c.socc_profile)) m.socm_inputs))
+ (String.concat "; " (List.map (string_var_from_index (snd c.socc_profile)) m.socm_outputs))
+
+
+let string_interface_of_method: (component -> step_method -> string) = fun c m ->
+ call_fun_ff (string_interface_of_method_ff c m)
+
+
+(* Méthode complète *)
+let string_of_method_ff: (component -> step_method -> Format.formatter -> unit) = fun c m ff ->
+
+ fprintf ff "@[<v>@[<v 2>";
+ string_interface_of_method_ff c m ff;
+
+ match m.socm_impl with
+ | None -> fprintf ff "@]@]"
+ | Some i ->
+ let locals, gaos = i in
+ fprintf ff ": {@;";
+ fprintf ff "@[<v>-- locals vars@;";
+ List.iter (
+ fun v ->
+ string_of_var_ff v ff;
+ fprintf ff ";@,";
+ ) locals;
+ fprintf ff "@]@;@[<v>-- code@;";
+ string_of_gaos_list_ff gaos ff;
+ fprintf ff "@]@]@ }@]"
+
+let string_of_method: (component -> step_method -> string) = fun c m ->
+ call_fun_ff (string_of_method_ff c m)
+
+
+(* Ordre des méthodes *)
+let string_of_precedence_ff: (string * string list -> Format.formatter -> unit) = fun (m, needs) ff ->
+ fprintf ff "%s < [%s]" m (String.concat "; " needs)
+
+let string_of_precedence: (string * string list -> string) = fun v ->
+ call_fun_ff (string_of_precedence_ff v)
+
+
+(** Profile d'un composant *)
+let string_of_profile_ff: Soc.var list * Soc.var list -> Format.formatter -> unit = fun (ins, outs) ff ->
+ fprintf ff "profile: @[(%s) ->@ (%s)@]"
+ (String.concat "; " (List.map string_of_var ins))
+ (String.concat "; " (List.map string_of_var outs))
+
+let string_of_profile: Soc.var list * Soc.var list -> string = fun profile ->
+ call_fun_ff (string_of_profile_ff profile)
+
+
+(* Convertion des éléments d'un composant *)
+(* Convertion du profil ... *)
+let string_of_component_profile_ff: (component -> Format.formatter -> unit) = fun comp ff ->
+ string_of_profile_ff comp.socc_profile ff
+
+let string_of_component_profile: (component -> string) = fun comp ->
+ call_fun_ff (string_of_component_profile_ff comp)
+
+(* ... des contraintes *)
+let string_of_comp_constraints_ff: (component -> Format.formatter -> unit) = fun comp ff ->
+ fprintf ff "constraints: @[";
+ match comp.socc_precedences with
+ | [] -> fprintf ff "[]@]"
+ | _ ->
+ fprintf ff "%s@]"
+ (String.concat "; " (List.map string_of_precedence comp.socc_precedences))
+
+let string_of_component_factory_ff: (
+ component -> Format.formatter ->
+ (component -> step_method -> Format.formatter -> unit) -> (* Formatage des méthodes *)
+ (memory -> Format.formatter -> unit) option -> (* Formatage des mémoires *)
+ unit
+) = fun comp ff format_meth format_mem ->
+ let display_mem () =
+ match format_mem with
+ | None -> ()
+ | Some f -> (
+ fprintf ff "@[<v 2>memories:@,";
+ List.iter (
+ fun m ->
+ f m ff;
+ fprintf ff ";@,"
+ ) comp.socc_memories
+ )
+ in
+ let display_init () =
+ match comp.socc_init with
+ | None -> fprintf ff "@[<v 2>init: -@]"
+ | Some m -> (
+ fprintf ff "@[<v 2>init:@,";
+ format_meth comp m ff;
+ fprintf ff "@]"
+ )
+ in
+
+ fprintf ff "@[<v>@[<v 2>component ";
+ string_of_component_key_ff comp.socc_key ff;
+ fprintf ff ":@,@[<v>";
+
+ string_of_component_profile_ff comp ff;
+ fprintf ff "@]@,@[<v>";
+
+ display_mem();
+ fprintf ff "@]@,@[<v>";
+
+ string_of_comp_constraints_ff comp ff;
+ fprintf ff "@]@,@[<v>";
+
+ display_init();
+ fprintf ff "@]@,@[<v>";
+
+ fprintf ff "@[<v 2>steps:@,";
+ List.iter (
+ fun s ->
+ fprintf ff "@[";
+ format_meth comp s ff;
+ fprintf ff "@]@,"
+ ) comp.socc_step;
+
+ fprintf ff "@]@]@]@]@."
+
+
+(* Interface d'un composant *)
+let string_interface_of_component_ff: (component -> Format.formatter -> unit) = fun comp ff ->
+ string_of_component_factory_ff comp ff
+ string_interface_of_method_ff
+ None
+
+let string_interface_of_component: (component -> string) = fun v ->
+ call_fun_ff (string_interface_of_component_ff v)
+
+
+(* Composant complet *)
+let string_of_component_ff: (component -> Format.formatter -> unit) = fun comp ff ->
+ string_of_component_factory_ff comp ff
+ string_of_method_ff
+ (Some string_of_memory_decl_ff)
+
+let string_of_component: (component -> string) = fun v ->
+ call_fun_ff (string_of_component_ff v)
+
+
+let dump_entete oc =
+ let time = Unix.localtime (Unix.time ()) in
+ let sys_call, _ = Array.fold_left
+ (fun (acc,i) x ->
+ if 70 < i + (String.length x) then
+ acc ^ "\n--\t\t" ^ x, String.length ("\n--\t\t" ^ x)
+ else
+ acc ^ " " ^ x , (i+1+(String.length x))
+ )
+ ("",0)
+ Sys.argv
+ and
+ date = (
+ (string_of_int time.Unix.tm_mday) ^ "/" ^
+ (string_of_int (time.Unix.tm_mon+1)) ^ "/" ^
+ (string_of_int (1900+time.Unix.tm_year))
+ )
+ and time_str = (
+ (string_of_int time.Unix.tm_hour) ^ ":" ^
+ (if time.Unix.tm_min < 10 then "0" else "") ^
+ (string_of_int time.Unix.tm_min) ^ ":" ^
+ (if time.Unix.tm_sec < 10 then "0" else "") ^
+ (string_of_int time.Unix.tm_sec)
+ )
+ (* and user = Unix.getlogin () *)
+ and hostname = Unix.gethostname ()
+ in
+ output_string oc
+ ("-- This file was generated by "^Sys.argv.(0)^" version " ^ Version.str ^
+ ".\n--\t" ^ sys_call ^ "
+-- on " ^ hostname ^
+ (* "by "^ user ^ *)
+ " the " ^ date ^ " at " ^ time_str ^ "\n\n");
+ flush oc
+
+
+let output: (bool -> string -> component list -> unit) =
+ fun no_header pkg_name components ->
+ let header = "Package '" ^ pkg_name ^ "' :" in
+ let deco = (String.make (String.length header) '=') in
+
+ if no_header then () else dump_entete stdout ;
+ print_string (deco ^ "\n" ^ header ^ "\n" ^ deco ^ "\n" ^ "\n");
+ print_string (
+ String.concat "\n\n" (List.map string_of_component components)
+ );
+ flush stdout
diff --git a/src/socUtils.mli b/src/socUtils.mli
new file mode 100644
index 00000000..3ce0371a
--- /dev/null
+++ b/src/socUtils.mli
@@ -0,0 +1,42 @@
+(** Time-stamp: <modified the 25/02/2013 (at 18:03) by Erwan Jahier> *)
+
+
+(** Donne toute les méthodes d'un composant. *)
+val get_all_methods: Soc.component -> Soc.step_method list
+
+
+(** Fonctions de représentation des objets SOC. *)
+val string_of_type_ref : Soc.var_type -> string
+val string_of_component_key : Soc.component_key -> string
+val string_of_var : Soc.var -> string
+val string_of_memory : Soc.memory -> string
+val string_of_operation : Soc.atomic_operation -> string
+val string_of_gao : Soc.gao -> string
+val string_of_gaos_list : Soc.gao list -> string
+val string_of_filter : Soc.var_expr -> string
+val string_of_method : Soc.component -> Soc.step_method -> string
+val string_interface_of_method : Soc.component -> Soc.step_method -> string
+val string_of_precedence : Soc.precedence -> string
+val string_of_profile : Soc.var list * Soc.var list -> string
+val string_interface_of_component : Soc.component -> string
+val string_of_component : Soc.component -> string
+
+val string_of_type_ref_ff : Soc.var_type -> Format.formatter -> unit
+val string_of_component_key_ff : Soc.component_key -> Format.formatter -> unit
+val string_of_var_ff : Soc.var -> Format.formatter -> unit
+val string_of_memory_ff : Soc.memory -> Format.formatter -> unit
+val string_of_operation_ff : Soc.atomic_operation -> Format.formatter -> unit
+val string_of_filter_ff : Soc.var_expr -> Format.formatter -> unit
+val string_of_gao_ff : Soc.gao -> Format.formatter -> unit
+val string_of_method_ff : Soc.component -> Soc.step_method -> Format.formatter -> unit
+val string_interface_of_method_ff : Soc.component -> Soc.step_method -> Format.formatter -> unit
+val string_of_precedence_ff : string * string list -> Format.formatter -> unit
+val string_of_profile_ff : Soc.var list * Soc.var list -> Format.formatter -> unit
+val string_interface_of_component_ff : Soc.component -> Format.formatter -> unit
+val string_of_component_ff : Soc.component -> Format.formatter -> unit
+
+
+(** [output header_flag pack_name] dumps the soc list into a
+ file. [header_flag] states whether or not headers (comment)
+ should be printed *)
+val output: bool -> string -> Soc.component list -> unit
diff --git a/src/toposort.ml b/src/toposort.ml
new file mode 100644
index 00000000..d1a72796
--- /dev/null
+++ b/src/toposort.ml
@@ -0,0 +1,39 @@
+(** See documentation in the .mli *)
+
+
+exception DependencyCycle of string * string list
+
+(** Do the actual topological sort.
+
+ This function takes several parameters :
+ @param acc this is the accumulator, which contains already sorted values
+ @param in_process contains values which are currently being processed (to detect cyclic dependencies)
+ @param to_sort this is the list to sort
+ @param dep_fun gives dependencies for a specific value from to_sort list *)
+let rec topological_sort_acc:
+ ('a -> string) -> 'a list -> 'a list -> 'a list -> ('a -> 'a list) -> 'a list =
+ fun a2str acc in_process to_sort dep_fun -> match to_sort with
+ | [] -> acc
+ | x::tl ->
+ if List.mem x in_process then
+ (* If this element is already marked as being processed, it must be
+ a cyclic dependency *)
+ raise (DependencyCycle(a2str x, List.map a2str in_process))
+
+ else if List.mem x acc then
+ (* If the element is already in the accumulator, it means
+ we've already sorted it. *)
+ topological_sort_acc a2str acc in_process tl dep_fun
+
+ else
+ (* Else, we compute the dependencies for this value *)
+ let dependencies = dep_fun x in
+ let dependencies_sorted =
+ topological_sort_acc a2str acc (x :: in_process) dependencies dep_fun
+ in
+ let acc = dependencies_sorted @ [x] in
+ topological_sort_acc a2str acc in_process tl dep_fun
+
+
+let f: ('a -> string) -> 'a list -> ('a -> 'a list) -> 'a list =
+ fun a2str to_sort dep_fun -> topological_sort_acc a2str [] [] to_sort dep_fun
diff --git a/src/toposort.mli b/src/toposort.mli
new file mode 100644
index 00000000..c517d2f0
--- /dev/null
+++ b/src/toposort.mli
@@ -0,0 +1,14 @@
+(** This module contains various tools used thorough the compiler. *)
+
+(** [topolocical_sort printer l dep_fun] does a topological sort on
+ the list [l], using the function [f] to find dependency in some
+ user-specific structure for each elements of [l], and recursively
+ for each dependencies found.
+
+ The dependency structure is unknown to this function, since [dep_fun] is
+ the interface between each other.
+
+ Throws a DependencyCycle exception a if cyclic dependency is found. *)
+val f : ('a -> string) -> 'a list -> ('a -> 'a list) -> 'a list
+
+exception DependencyCycle of string * string list
diff --git a/test/lus2lic.sum b/test/lus2lic.sum
index 322c9529..3d235b10 100644
--- a/test/lus2lic.sum
+++ b/test/lus2lic.sum
@@ -1,4 +1,4 @@
-Test Run By jahier on Wed Feb 13 14:16:05 2013
+Test Run By jahier on Mon Feb 25 18:13:41 2013
Native configuration is i686-pc-linux-gnu
=== lus2lic tests ===
diff --git a/test/lus2lic.time b/test/lus2lic.time
index dfafd0d5..76997001 100644
--- a/test/lus2lic.time
+++ b/test/lus2lic.time
@@ -1,2 +1,2 @@
-testcase ./lus2lic.tests/non-reg.exp completed in 23 seconds
+testcase ./lus2lic.tests/non-reg.exp completed in 24 seconds
testcase ./lus2lic.tests/progression.exp completed in 0 seconds
--
GitLab