From a0ee285c6f638bb3ab8c6de5693ab61759cf0135 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Thu, 28 Aug 2008 10:33:23 +0200
Subject: [PATCH] untabify all files.
---
src/compile.ml | 32 +-
src/compiledData.ml | 176 +++---
src/evalClock.ml | 246 ++++----
src/evalConst.ml | 684 ++++++++++-----------
src/evalType.ml | 206 +++----
src/expandPack.ml | 310 +++++-----
src/getEff.ml | 440 +++++++-------
src/ident.ml | 6 +-
src/lazyCompiler.ml | 814 ++++++++++++-------------
src/lexer.mll | 426 +++++++-------
src/licDump.ml | 258 ++++----
src/lxm.ml | 20 +-
src/main.ml | 158 ++---
src/parser.mly | 1276 ++++++++++++++++++++--------------------
src/parserUtils.ml | 192 +++---
src/predef.ml | 10 +-
src/predefEvalClock.ml | 6 +-
src/predefEvalConst.ml | 154 ++---
src/predefEvalType.ml | 184 +++---
19 files changed, 2799 insertions(+), 2799 deletions(-)
diff --git a/src/compile.ml b/src/compile.ml
index e398361b..305670bc 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/07/2008 (at 10:55) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:24) by Erwan Jahier> *)
open Lxm
@@ -34,18 +34,18 @@ let (doit : SyntaxTree.pack_or_model list -> Ident.idref option -> unit) =
match main_node with
| None -> LazyCompiler.compile_all lzcomp
| Some main_node ->
- (* la clée "absolue" du main node (pas d'args statiques) *)
- let main_node_key =
- CompiledData.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);
-
- if !Global.compile_all_items then
- LazyCompiler.compile_all lzcomp
- else
- ignore(LazyCompiler.node_check lzcomp main_node_key
- (match Ident.pack_of_idref main_node with
- | None -> Lxm.dummy ""
- | Some pn -> Lxm.dummy (Ident.pack_name_to_string pn)))
+ (* la clée "absolue" du main node (pas d'args statiques) *)
+ let main_node_key =
+ CompiledData.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);
+
+ if !Global.compile_all_items then
+ LazyCompiler.compile_all lzcomp
+ else
+ ignore(LazyCompiler.node_check lzcomp main_node_key
+ (match Ident.pack_of_idref main_node with
+ | None -> Lxm.dummy ""
+ | Some pn -> Lxm.dummy (Ident.pack_name_to_string pn)))
diff --git a/src/compiledData.ml b/src/compiledData.ml
index 472ca6bd..c160cf4c 100644
--- a/src/compiledData.ml
+++ b/src/compiledData.ml
@@ -1,86 +1,86 @@
-(** Time-stamp: <modified the 27/08/2008 (at 15:40) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:26) by Erwan Jahier> *)
(**
*)
(*----------------------------------------------------------------------
- module : CompiledData
- date :
+ module : CompiledData
+ date :
------------------------------------------------------------------------
- DESCRIPTION :
+ DESCRIPTION :
- Définition des structures de données utilisée pour la compil,
- plus des utilitaires pour les messages d'erreurs, de bug etc.
- N.B. on utilise beaucoup l'adjectif "effectif", qui signifie
- simplement "correct".
+ Définition des structures de données utilisée pour la compil,
+ plus des utilitaires pour les messages d'erreurs, de bug etc.
+ N.B. on utilise beaucoup l'adjectif "effectif", qui signifie
+ simplement "correct".
- REMARQUE GENERALE :
+ REMARQUE GENERALE :
- D'une manière générale, la compil d'une entité syntaxique
- "toto" est implémentée par une fonction check_toto, qui
- prend en entrée (entr'autre) un toto et renvoie un
- toto_eff.
+ D'une manière générale, la compil d'une entité syntaxique
+ "toto" est implémentée par une fonction check_toto, qui
+ prend en entrée (entr'autre) un toto et renvoie un
+ toto_eff.
- TYPES DE DONNEES :
+ TYPES DE DONNEES :
- - type_eff :
- dénotation de type effectif, implémente l'équivalence des types,
- construit à partir d'une type_exp.
+ - type_eff :
+ dénotation de type effectif, implémente l'équivalence des types,
+ construit à partir d'une type_exp.
- - const_eff :
- dénotation de constante effective,
- construit à partir d'une val_exp => IL S'AGIT DE LA REPRESENTATION
- INTERNE DES CONSTANTES STATIQUES
+ - const_eff :
+ dénotation de constante effective,
+ construit à partir d'une val_exp => IL S'AGIT DE LA REPRESENTATION
+ INTERNE DES CONSTANTES STATIQUES
- - var_info_eff :
- déclaration de variable,
- construit à partir de var_info.
+ - var_info_eff :
+ déclaration de variable,
+ construit à partir de var_info.
- - val_eff :
- union entre const_eff et var_info_eff.
+ - val_eff :
+ union entre const_eff et var_info_eff.
- - slice_info_eff :
- dénotation de tranche de tableau,
- construit à partir de slice_info.
+ - slice_info_eff :
+ dénotation de tranche de tableau,
+ construit à partir de slice_info.
- - left_eff :
- version compilée de left_part
+ - left_eff :
+ version compilée de left_part
- - eq_info_eff :
- version compilée de eq_info
+ - eq_info_eff :
+ version compilée de eq_info
- - node_exp_eff :
- dénotation d'opération,
- peut être predef ou utilisateur,
- construit à partir de node_exp.
+ - node_exp_eff :
+ dénotation d'opération,
+ peut être predef ou utilisateur,
+ construit à partir de node_exp.
- - static_arg_eff :
- déclaration d'un static arg
+ - static_arg_eff :
+ déclaration d'un static arg
- - pack_env :
- la "grosse" structure de données qui gère la compilation
- des packages => implémentée dans CheckGlobal pour la partie type/const/function
- (initialisation) et dans CheckNode pour la partie node/template qui
- est faite à la demande.
+ - pack_env :
+ la "grosse" structure de données qui gère la compilation
+ des packages => implémentée dans CheckGlobal pour la partie type/const/function
+ (initialisation) et dans CheckNode pour la partie node/template qui
+ est faite à la demande.
- - local_env :
- structure qui gère l'environnement de compilation
- d'un noeud/template.
+ - local_env :
+ structure qui gère l'environnement de compilation
+ d'un noeud/template.
- TYPES FONCTIONNEL :
+ TYPES FONCTIONNEL :
- - id_solver (en fait, une structure qui contient plusieurs fonctions,
- une pour traiter les constantes, une pour traiter les types)
+ - id_solver (en fait, une structure qui contient plusieurs fonctions,
+ une pour traiter les constantes, une pour traiter les types)
- UTILITAIRES :
+ UTILITAIRES :
- - type_of_const_eff : renvoie le type_eff d'une const_eff
- - string_of_type_eff : pretty-print d'un type_eff
- - string_of_const_eff : pretty-print d'une const_eff
- - string_of_node_key : pretty-print d'un node_key
- _ string_of_slice_eff :
+ - type_of_const_eff : renvoie le type_eff d'une const_eff
+ - string_of_type_eff : pretty-print d'un type_eff
+ - string_of_const_eff : pretty-print d'une const_eff
+ - string_of_node_key : pretty-print d'un node_key
+ _ string_of_slice_eff :
----------------------------------------------------------------------*)
@@ -92,12 +92,12 @@ open SyntaxTreeCore
(*---------------------------------------------------------------------
Type : id_solver
-----------------------------------------------------------------------
- Joue le rôle d'environnemnt : contient des fonctions
- pour résoudre les réferences aux idents.
- (voir par exemple EvalConst, EvalType)
+ Joue le rôle d'environnemnt : contient des fonctions
+ pour résoudre les réferences aux idents.
+ (voir par exemple EvalConst, EvalType)
N.B. On fournit les constructeurs des id_solver courants, voir :
-
+
----------------------------------------------------------------------*)
type id_solver = {
(* XXX I should not have [idref] in this module !!! *)
@@ -117,7 +117,7 @@ type id_solver = {
- pas d'alias
- taille des tableaux résolues
----------------------------------------------------------------------*)
-
+
and type_eff =
| Bool_type_eff
| Int_type_eff
@@ -223,19 +223,19 @@ and const_eff =
(* type tableau : liste des valeurs + type des elts + taille *)
| Array_const_eff of (const_eff array * type_eff)
(*---------------------------------------------------------------------
- Type: val_eff
- -----------------------------------------------------------------------
- Une constante ou une variable
- => item de la table des symboles de valeurs
- ----------------------------------------------------------------------*)
+ Type: val_eff
+ -----------------------------------------------------------------------
+ Une constante ou une variable
+ => item de la table des symboles de valeurs
+ ----------------------------------------------------------------------*)
(* and val_eff = *)
(* ConstEff of const_eff *)
(* | VarEff of var_info_eff *)
(*---------------------------------------------------------------------
- Type: var_info_eff
- -----------------------------------------------------------------------
- Info associée à un ident de variable
- ----------------------------------------------------------------------*)
+ Type: var_info_eff
+ -----------------------------------------------------------------------
+ Info associée à un ident de variable
+ ----------------------------------------------------------------------*)
(* ICI à completer/modifier sans doute *)
and var_info_eff = {
var_name_eff : Ident.t;
@@ -289,7 +289,7 @@ and static_arg_eff =
| NodeStaticArgEff of (Ident.t * node_exp_eff)
-
+
(****************************************************************************)
(** Type check_flag
@@ -369,31 +369,31 @@ let (lookup_node: local_env -> Ident.idref -> static_arg_eff list -> Lxm.t ->
let (lookup_const: local_env -> Ident.idref -> Lxm.t -> const_eff) =
fun env id lmx ->
Hashtbl.find env.lenv_const (Ident.name_of_idref id)
-
+
let (lookup_var: local_env -> Ident.t -> Lxm.t -> var_info_eff) =
fun env id lmx ->
Hashtbl.find env.lenv_vars id
-
+
let (make_local_env : node_key -> local_env) =
fun nk ->
let res =
{
- lenv_node_key = nk;
- lenv_types = Hashtbl.create 0;
- lenv_const = Hashtbl.create 0;
- lenv_nodes = Hashtbl.create 0;
- lenv_vars = Hashtbl.create 0;
+ lenv_node_key = nk;
+ lenv_types = Hashtbl.create 0;
+ lenv_const = Hashtbl.create 0;
+ lenv_nodes = Hashtbl.create 0;
+ lenv_vars = Hashtbl.create 0;
}
in
(* fill tables using static arg info *)
List.iter
- (function
- | ConstStaticArgEff(id,ce) -> Hashtbl.add res.lenv_const id ce
- | TypeStaticArgEff(id,te) -> Hashtbl.add res.lenv_types id te
- | NodeStaticArgEff(id, ne) -> Hashtbl.add res.lenv_nodes id ne
- )
- (snd nk);
+ (function
+ | ConstStaticArgEff(id,ce) -> Hashtbl.add res.lenv_const id ce
+ | TypeStaticArgEff(id,te) -> Hashtbl.add res.lenv_types id te
+ | NodeStaticArgEff(id, ne) -> Hashtbl.add res.lenv_nodes id ne
+ )
+ (snd nk);
res
@@ -431,10 +431,10 @@ let rec (subst_type : type_eff -> type_eff -> type_eff) =
| External_type_eff l -> External_type_eff l
| Enum_type_eff(l,el) -> Enum_type_eff(l,el)
| Array_type_eff(teff_ext,i) ->
- Array_type_eff(subst_type t teff_ext, i)
+ Array_type_eff(subst_type t teff_ext, i)
| Struct_type_eff(l, fl) ->
- Struct_type_eff(
- l, List.map (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt))) fl)
+ Struct_type_eff(
+ l, List.map (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt))) fl)
| Any
| Overload -> t
@@ -448,7 +448,7 @@ let (type_of_const_eff: const_eff -> type_eff) =
| Enum_const_eff (s, teff) -> teff
| Struct_const_eff (fl, teff) -> teff
| Array_const_eff (ct, teff) -> Array_type_eff (teff, Array.length ct)
-
+
let (type_eff_of_left_eff: left_eff -> type_eff) =
function
diff --git a/src/evalClock.ml b/src/evalClock.ml
index f613700b..622e59af 100644
--- a/src/evalClock.ml
+++ b/src/evalClock.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 21/08/2008 (at 15:50) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:26) by Erwan Jahier> *)
open Predef
@@ -92,20 +92,20 @@ let rec (var_info_eff_of_left_eff: left_eff -> var_info_eff) =
| LeftFieldEff (l, id,_) ->
let v = var_info_eff_of_left_eff l in
let new_name = (Ident.to_string v.var_name_eff) ^ "." ^ (Ident.to_string id) in
- { v with var_name_eff = Ident.of_string new_name }
+ { v with var_name_eff = Ident.of_string new_name }
| LeftArrayEff (l,i,_) ->
let v = var_info_eff_of_left_eff l in
let new_name = (Ident.to_string v.var_name_eff) ^ "[" ^
- (string_of_int i) ^ "]"
+ (string_of_int i) ^ "]"
in
- { v with var_name_eff = Ident.of_string new_name }
+ { v with var_name_eff = Ident.of_string new_name }
| LeftSliceEff (l,si,_) ->
let v = var_info_eff_of_left_eff l in
let new_name = (Ident.to_string v.var_name_eff) ^ (string_of_slice_info_eff si)
in
- { v with var_name_eff = Ident.of_string new_name }
+ { v with var_name_eff = Ident.of_string new_name }
let var_info_eff_to_clock_eff v = v.var_clock_eff
@@ -130,33 +130,33 @@ let rec (is_a_sub_clock : Lxm.t -> subst -> clock_eff -> clock_eff -> subst opti
sens). Returns Some updated substitution if it is the case,
and None otherwise *)
match sc,c with
- (* the base clock is a sub-clock of all clocks *)
+ (* the base clock is a sub-clock of all clocks *)
| BaseEff, (BaseEff|On(_,_)|ClockVar _) -> Some s
| On(v,clk), BaseEff -> None
| On(v,clk), On(v2,clk2) -> (
- try Some(UnifyClock.f lxm s clk clk2)
- with _ -> is_a_sub_clock lxm s sc clk2
- )
+ try Some(UnifyClock.f lxm s clk clk2)
+ with _ -> is_a_sub_clock lxm s sc clk2
+ )
| ClockVar j, BaseEff -> assert false
| ClockVar i, On(_,_)
| ClockVar i, ClockVar _ ->
- (* XXX can it occur? if yes, something should be done
- the problem being that several things are possible
- (there is no unique sub-clock of a clock...
+ (* XXX can it occur? if yes, something should be done
+ the problem being that several things are possible
+ (there is no unique sub-clock of a clock...
- Well, ok, let's suppose that they are equal for the time being,
- which seems wrong in the general case.
- *)
- let s1,s2 = s in
- Some (s1,(i,c)::s2)
+ Well, ok, let's suppose that they are equal for the time being,
+ which seems wrong in the general case.
+ *)
+ let s1,s2 = s in
+ Some (s1,(i,c)::s2)
| On(_,_), ClockVar i -> (* Ditto *)
- let s1,s2 = s in
- Some (s1,(i,sc)::s2)
+ let s1,s2 = s in
+ Some (s1,(i,sc)::s2)
-
+
type clock_profile = clock_eff list * clock_eff list
let (get_clock_profile : node_exp_eff -> clock_profile) =
@@ -240,12 +240,12 @@ and f_aux id_solver s ve =
let cel, s =
match ve with
| CallByPosEff ({it=posop; src=lxm}, OperEff args) ->
- eval_by_pos_clock id_solver posop lxm args s
-
+ eval_by_pos_clock id_solver posop lxm args s
+
| CallByNameEff ({it=nmop; src=lxm}, nmargs ) ->
- try eval_by_name_clock id_solver nmop lxm nmargs s
- with EvalConst_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+ try eval_by_name_clock id_solver nmop lxm nmargs s
+ with EvalConst_error msg ->
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
in
tabulate_res ve cel;
cel, s
@@ -255,7 +255,7 @@ and (f_list : id_solver -> subst -> val_exp_eff list -> clock_eff list list * su
fun id_solver s args ->
let aux (acc,s) arg =
let cil, s = f_aux id_solver s arg in
- (cil::acc, s)
+ (cil::acc, s)
in
let (cil, s) = List.fold_left aux ([],s) args in
let cil = List.rev cil in
@@ -266,96 +266,96 @@ and (eval_by_pos_clock : id_solver -> by_pos_op_eff -> Lxm.t -> val_exp_eff list
fun id_solver posop lxm args s ->
match posop with
| CURRENT_eff -> ( (* we return the clock of the argument *)
- let clocks_of_args, s = f_list id_solver s args in
- match List.flatten clocks_of_args with
- | [BaseEff] -> [BaseEff],s
- | [On(_,clk)] -> [clk],s
- | _ -> assert false
- )
+ let clocks_of_args, s = f_list id_solver s args in
+ match List.flatten clocks_of_args with
+ | [BaseEff] -> [BaseEff],s
+ | [On(_,clk)] -> [clk],s
+ | _ -> assert false
+ )
| WHENOT_eff clk_var -> assert false (* use merge when it is implemented *)
| WHEN_eff clk_var -> (
- let clk = var_info_eff_to_clock_eff clk_var in
- (match f_list id_solver s args with
- | [[c1];_], s -> (
- match is_a_sub_clock lxm s c1 clk with
- | None ->
- let msg = "\n*** clock error: '" ^ (ci2str (c1)) ^
- "' is not a sub-clock of '" ^ (ci2str (clk)) ^ "'"
- in
- raise (Compile_error(lxm, msg))
- | Some s ->
- let clk_of_c1,s =
- match c1 with
- | BaseEff -> assert false
- | On(var,_) -> On(var, clk), s
- | ClockVar i ->
- let cc1 = On(make_dummy_var "const",clk) in
- let (s1,s2) = s in
- cc1, (s1,(i,cc1)::s2)
- in
- ([clk_of_c1], s)
- )
- | [c1;_], s ->
- let msg = "when on tuples not yet supported." in
- raise (Compile_error(lxm, msg))
-
- | _ -> assert false (* "(x1,x2) when node (x,y)" *)
- )
- )
+ let clk = var_info_eff_to_clock_eff clk_var in
+ (match f_list id_solver s args with
+ | [[c1];_], s -> (
+ match is_a_sub_clock lxm s c1 clk with
+ | None ->
+ let msg = "\n*** clock error: '" ^ (ci2str (c1)) ^
+ "' is not a sub-clock of '" ^ (ci2str (clk)) ^ "'"
+ in
+ raise (Compile_error(lxm, msg))
+ | Some s ->
+ let clk_of_c1,s =
+ match c1 with
+ | BaseEff -> assert false
+ | On(var,_) -> On(var, clk), s
+ | ClockVar i ->
+ let cc1 = On(make_dummy_var "const",clk) in
+ let (s1,s2) = s in
+ cc1, (s1,(i,cc1)::s2)
+ in
+ ([clk_of_c1], s)
+ )
+ | [c1;_], s ->
+ let msg = "when on tuples not yet supported." in
+ raise (Compile_error(lxm, msg))
+
+ | _ -> assert false (* "(x1,x2) when node (x,y)" *)
+ )
+ )
| MERGE_eff _ -> assert false
- (* f_aux id_solver (List.hd args) *)
+ (* f_aux id_solver (List.hd args) *)
| HAT_eff(i,ve) -> f_aux id_solver s ve
- (* nb: the args have been put inside the HAT_eff constructor *)
-
+ (* nb: the args have been put inside the HAT_eff constructor *)
+
| CONST_eff (idref,_) -> [get_constant_clock ()],s
| IDENT_eff idref -> (
- try ([var_info_eff_to_clock_eff (id_solver.id2var idref lxm)], s)
- with _ -> (* => it is a constant *) [get_constant_clock ()],s
- )
+ try ([var_info_eff_to_clock_eff (id_solver.id2var idref lxm)], s)
+ with _ -> (* => it is a constant *) [get_constant_clock ()],s
+ )
| CALL_eff node_exp_eff ->
- let (cil_arg, cil_res) = get_clock_profile node_exp_eff.it in
- (* the value of the base clock of a node is actually relative
- to the context into which the node is called.
-
- Hence we create a fresh var clock, that will be instanciated
- by the caller.
- *)
- let rel_base = ClockVar (UnifyClock.get_var_type ()) in
- let rec (replace_base : clock_eff -> clock_eff -> clock_eff) =
- fun rel_base ci ->
- (* [replace_base rel_base ci ] replaces in [ci] any occurences of the
- base clock by [rel_base] *)
- match ci with
- | BaseEff -> rel_base
- | On(v,clk) -> On(v, replace_base rel_base clk)
- | ClockVar i -> ci
- in
- let cil_arg = List.map (replace_base rel_base) cil_arg in
- let cil_res = List.map (replace_base rel_base) cil_res in
- let clk_args, s = f_list id_solver s args in
- let s = check_args lxm s cil_arg (List.flatten clk_args) in
- List.map (apply_subst s) cil_res, s
+ let (cil_arg, cil_res) = get_clock_profile node_exp_eff.it in
+ (* the value of the base clock of a node is actually relative
+ to the context into which the node is called.
+
+ Hence we create a fresh var clock, that will be instanciated
+ by the caller.
+ *)
+ let rel_base = ClockVar (UnifyClock.get_var_type ()) in
+ let rec (replace_base : clock_eff -> clock_eff -> clock_eff) =
+ fun rel_base ci ->
+ (* [replace_base rel_base ci ] replaces in [ci] any occurences of the
+ base clock by [rel_base] *)
+ match ci with
+ | BaseEff -> rel_base
+ | On(v,clk) -> On(v, replace_base rel_base clk)
+ | ClockVar i -> ci
+ in
+ let cil_arg = List.map (replace_base rel_base) cil_arg in
+ let cil_res = List.map (replace_base rel_base) cil_res in
+ let clk_args, s = f_list id_solver s args in
+ let s = check_args lxm s cil_arg (List.flatten clk_args) in
+ List.map (apply_subst s) cil_res, s
(* One argument. *)
| PRE_eff
| STRUCT_ACCESS_eff _
| ARRAY_ACCES_eff (_, _)
| ARRAY_SLICE_eff (_,_) ->
- assert(List.length args = 1);
- f_aux id_solver s (List.hd args)
+ assert(List.length args = 1);
+ f_aux id_solver s (List.hd args)
| Predef_eff (op,sargs) ->
- let clk_args, s = f_list id_solver s args in
+ let clk_args, s = f_list id_solver s args in
- let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
- let clk_list, s =
- if args = [] then [],s else
- let _clk,s = UnifyClock.list lxm flat_clk_args s in
- List.map (List.map (apply_subst s)) clk_args, s
- in
- PredefEvalClock.f op lxm sargs clk_list, s
+ let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
+ let clk_list, s =
+ if args = [] then [],s else
+ let _clk,s = UnifyClock.list lxm flat_clk_args s in
+ List.map (List.map (apply_subst s)) clk_args, s
+ in
+ PredefEvalClock.f op lxm sargs clk_list, s
(* may have tuples as arguments *)
| TUPLE_eff
@@ -363,25 +363,25 @@ and (eval_by_pos_clock : id_solver -> by_pos_op_eff -> Lxm.t -> val_exp_eff list
| FBY_eff
| CONCAT_eff
| ARRAY_eff -> (
- (* Check that all args are of the same (unifiable) clocks.
-
- XXX : we suppose that all those operators are
- mono-clocks (i.e., when they return tuples, all elements
- are on the same clock). It would be sensible to have,
- e.g., arrows on multiple clocks. We'll refine later. *)
- let clk_args, s = f_list id_solver s args in
- let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
- let clk,s = UnifyClock.list lxm flat_clk_args s in
- let clk_list =
- match posop with
- | TUPLE_eff -> List.map (apply_subst s) flat_clk_args
- | _ -> List.map (apply_subst s) (List.hd clk_args)
- in
- clk_list, s
- )
+ (* Check that all args are of the same (unifiable) clocks.
+
+ XXX : we suppose that all those operators are
+ mono-clocks (i.e., when they return tuples, all elements
+ are on the same clock). It would be sensible to have,
+ e.g., arrows on multiple clocks. We'll refine later. *)
+ let clk_args, s = f_list id_solver s args in
+ let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
+ let clk,s = UnifyClock.list lxm flat_clk_args s in
+ let clk_list =
+ match posop with
+ | TUPLE_eff -> List.map (apply_subst s) flat_clk_args
+ | _ -> List.map (apply_subst s) (List.hd clk_args)
+ in
+ clk_list, s
+ )
| WITH_eff(ve) -> f_aux id_solver s ve
-
-
+
+
and (eval_by_name_clock : id_solver -> by_name_op_eff -> Lxm.t ->
(Ident.t Lxm.srcflagged * val_exp_eff) list -> subst ->
@@ -390,10 +390,10 @@ and (eval_by_name_clock : id_solver -> by_name_op_eff -> Lxm.t ->
match namop with
| STRUCT_anonymous_eff -> assert false (* cf EvalType.f *)
| STRUCT_eff _ ->
- let args = List.map (fun (id,ve) -> ve) namargs in
- (* XXX The 3 following lines duplicates the code of TUPLE_eff and co *)
- let clk_args, s = f_list id_solver s args in
- let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
- let clk,s = UnifyClock.list lxm flat_clk_args s in
- let clk_list = List.map (apply_subst s) (List.hd clk_args) in
- clk_list, s
+ let args = List.map (fun (id,ve) -> ve) namargs in
+ (* XXX The 3 following lines duplicates the code of TUPLE_eff and co *)
+ let clk_args, s = f_list id_solver s args in
+ let flat_clk_args = List.flatten clk_args in (* => mono-clock! *)
+ let clk,s = UnifyClock.list lxm flat_clk_args s in
+ let clk_list = List.map (apply_subst s) (List.hd clk_args) in
+ clk_list, s
diff --git a/src/evalConst.ml b/src/evalConst.ml
index 188203a7..ac108ca5 100644
--- a/src/evalConst.ml
+++ b/src/evalConst.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/07/2008 (at 10:55) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:26) by Erwan Jahier> *)
open Printf
@@ -13,7 +13,7 @@ open PredefEvalType
(*----------------------------------------------------
EvalArray_error :
- - levée par les fonctions dédiées aux tableaux
+ - levée par les fonctions dédiées aux tableaux
----------------------------------------------------*)
exception EvalArray_error of string
@@ -27,8 +27,8 @@ let finish_me msg = print_string ("\n\tXXX evalConst.ml:"^msg^" -> finish me!\n
let not_evaluable_construct str =
raise (EvalConst_error(
- Printf.sprintf "The construct %s is not allowed in static expression"
- str))
+ Printf.sprintf "The construct %s is not allowed in static expression"
+ str))
(*----------------------------------------------------
Utilitaire :
@@ -52,27 +52,27 @@ let (make_array_const : const_eff list array -> const_eff) =
let expected_type = ref None in
let treat_arg (op : const_eff list) =
match op with
- | [x] -> (
- (* non tuple *)
- let xtyp = type_of_const_eff x in
- match (!expected_type) with
- | None -> expected_type := Some xtyp; x
- | Some t -> (
- if (t = xtyp) then x else
- raise (EvalConst_error(
- "type error in array, "^
- (LicDump.string_of_type_eff xtyp)^
- " mixed with " ^ LicDump.string_of_type_eff t
- ))
- )
- )
- | _ -> (* tuple *)
- raise (EvalConst_error("array of tuple not allowed"))
+ | [x] -> (
+ (* non tuple *)
+ let xtyp = type_of_const_eff x in
+ match (!expected_type) with
+ | None -> expected_type := Some xtyp; x
+ | Some t -> (
+ if (t = xtyp) then x else
+ raise (EvalConst_error(
+ "type error in array, "^
+ (LicDump.string_of_type_eff xtyp)^
+ " mixed with " ^ LicDump.string_of_type_eff t
+ ))
+ )
+ )
+ | _ -> (* tuple *)
+ raise (EvalConst_error("array of tuple not allowed"))
in
let res = Array.map treat_arg ops in
match (!expected_type) with
- | None -> raise (EvalConst_error("empty array"))
- | Some t -> Array_const_eff(res, t)
+ | None -> raise (EvalConst_error("empty array"))
+ | Some t -> Array_const_eff(res, t)
@@ -86,296 +86,296 @@ let make_struct_const
(
(* on verifie qu'on a bien un type struct *)
match teff with
- Struct_type_eff (tnm, flst) -> (
- (* on construit la liste dans le BON ordre *)
- let make_eff_field ((fn: Ident.t),((ft:type_eff),(fv:const_eff option))) = (
- try (
- (* on prend en priorité dans arg_tab *)
- match (Hashtbl.find arg_tab fn) with
- (lxm, v) -> (
- (* effet de bord : on vire la valeur de arg_tab *)
- Hashtbl.remove arg_tab fn ;
- let vt = type_of_const_eff v in
- if (vt = ft) then (fn, v) (*ok*)
- else raise (Compile_error(
- lxm ,
- sprintf
- "\n*** type error in struct %s, %s instead of %s"
- (Ident.string_of_long tnm)
- (LicDump.string_of_type_eff vt)
- (LicDump.string_of_type_eff ft)
- ))
- )
- ) with Not_found -> (
- (* sinon la valeur par défaut *)
- match fv with
- Some v -> (fn, v) (* ok : v correcte par construction *)
- | None ->
- raise (EvalConst_error(
- sprintf
- "bad struct expression, no value given for field %s"
- (Ident.to_string fn)
- ))
- )
- ) in
- (* on mappe flst pour avoir la liste dans le bon ordre *)
- let eff_fields = List.map make_eff_field flst in
- (* si arg_tab n'est pas vide, erreur sur le premier *)
- let raise_error (id : Ident.t) ((lxm : Lxm.t), (veff : const_eff))
- = raise(Compile_error(
- lxm,
- sprintf
- "\n*** %s is not a field of struct %s"
- (Ident.to_string id)
- (LicDump.string_of_type_eff(teff))
- ))
- in
- Hashtbl.iter raise_error arg_tab ;
- (* ok : tout s'est bien passé ! *)
- Struct_const_eff (eff_fields, teff)
- )
+ Struct_type_eff (tnm, flst) -> (
+ (* on construit la liste dans le BON ordre *)
+ let make_eff_field ((fn: Ident.t),((ft:type_eff),(fv:const_eff option))) = (
+ try (
+ (* on prend en priorité dans arg_tab *)
+ match (Hashtbl.find arg_tab fn) with
+ (lxm, v) -> (
+ (* effet de bord : on vire la valeur de arg_tab *)
+ Hashtbl.remove arg_tab fn ;
+ let vt = type_of_const_eff v in
+ if (vt = ft) then (fn, v) (*ok*)
+ else raise (Compile_error(
+ lxm ,
+ sprintf
+ "\n*** type error in struct %s, %s instead of %s"
+ (Ident.string_of_long tnm)
+ (LicDump.string_of_type_eff vt)
+ (LicDump.string_of_type_eff ft)
+ ))
+ )
+ ) with Not_found -> (
+ (* sinon la valeur par défaut *)
+ match fv with
+ Some v -> (fn, v) (* ok : v correcte par construction *)
+ | None ->
+ raise (EvalConst_error(
+ sprintf
+ "bad struct expression, no value given for field %s"
+ (Ident.to_string fn)
+ ))
+ )
+ ) in
+ (* on mappe flst pour avoir la liste dans le bon ordre *)
+ let eff_fields = List.map make_eff_field flst in
+ (* si arg_tab n'est pas vide, erreur sur le premier *)
+ let raise_error (id : Ident.t) ((lxm : Lxm.t), (veff : const_eff))
+ = raise(Compile_error(
+ lxm,
+ sprintf
+ "\n*** %s is not a field of struct %s"
+ (Ident.to_string id)
+ (LicDump.string_of_type_eff(teff))
+ ))
+ in
+ Hashtbl.iter raise_error arg_tab ;
+ (* ok : tout s'est bien passé ! *)
+ Struct_const_eff (eff_fields, teff)
+ )
| _ -> raise (EvalConst_error(
- sprintf
- "struct type expected instead of %s"
- (LicDump.string_of_type_eff teff)
- ))
+ sprintf
+ "struct type expected instead of %s"
+ (LicDump.string_of_type_eff teff)
+ ))
)
let l2ll l = if l = [] then [] else [l]
(*----------------------------------------------------
- Evaluation récursive des expressions constantes
+ Evaluation récursive des expressions constantes
------------------------------------------------------
f :
- - entrées : id_solver et val_exp
- - sortie : const_eff list
- - Effet de bord : Compile_error
+ - entrées : id_solver et val_exp
+ - sortie : const_eff list
+ - Effet de bord : Compile_error
Rôle :
- -> résoud les références aux idents
- -> gère les appels récursifs (évaluation des arguments)
+ -> résoud les références aux idents
+ -> gère les appels récursifs (évaluation des arguments)
----------------------------------------------------*)
let rec f
(env : id_solver)
(vexp : val_exp)
= (
(*-----------------------------------
- fonction récursive principale
- -> capte les nv
- -> récupère les EvalConst_error
- -----------------------------------*)
+ fonction récursive principale
+ -> capte les nv
+ -> récupère les EvalConst_error
+ -----------------------------------*)
let rec rec_eval_const (vexp : val_exp) = (
- match vexp with
- | CallByPos ({it=posop; src=lxm}, Oper args) -> (
- try eval_by_pos_const posop lxm args
- with
- | EvalType_error msg ->
- raise (Compile_error(lxm, "type error: "^msg))
- | EvalConst_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
- )
- | CallByName ({it=nmop; src=lxm}, nmargs ) -> (
- try eval_by_name_const nmop lxm nmargs
- with EvalConst_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
- )
+ match vexp with
+ | CallByPos ({it=posop; src=lxm}, Oper args) -> (
+ try eval_by_pos_const posop lxm args
+ with
+ | EvalType_error msg ->
+ raise (Compile_error(lxm, "type error: "^msg))
+ | EvalConst_error msg ->
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+ )
+ | CallByName ({it=nmop; src=lxm}, nmargs ) -> (
+ try eval_by_name_const nmop lxm nmargs
+ with EvalConst_error msg ->
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+ )
)
- (*-----------------------------------
- fonction récursive secondaire
- eval. exp classique (by pos)
- N.B. On distingue les opérations
- classiques (avec extention tableau
- implicie) des autres. Ici, on traite
- toutes les opérations non classiques.
- -----------------------------------*)
+ (*-----------------------------------
+ fonction récursive secondaire
+ eval. exp classique (by pos)
+ N.B. On distingue les opérations
+ classiques (avec extention tableau
+ implicie) des autres. Ici, on traite
+ toutes les opérations non classiques.
+ -----------------------------------*)
and eval_by_pos_const
- (posop : by_pos_op) (* l'operateur *)
- (lxm : Lxm.t) (* source de l'opérateur *)
- (args : val_exp list) (* arguments *)
- = (
- match (posop) with
- (* capte les idents de constantes *)
- IDENT_n id -> (
- (* 2007-07 on interdit les externes *)
- match (env.id2const id lxm) with
- | Extern_const_eff(_,_, Some const_eff) -> [const_eff]
- | Extern_const_eff(_,_,None) ->
- raise (EvalConst_error(
- sprintf "\n*** cannot access this abstract constant value"))
- | x -> [ x ]
- )
- (* opérateur lazzy *)
- | WITH_n(a0,a1,a2) -> (
- match (rec_eval_const a0) with
- [ Bool_const_eff true] -> rec_eval_const a1
- | [ Bool_const_eff false] -> rec_eval_const a2
- | x -> type_error_const x "bool"
- )
- (* mettre à plat la liste des args *)
- | TUPLE_n -> ( List.flatten (List.map rec_eval_const args))
- (* les tableaux de tuples sont interdits *)
- | HAT_n -> (
- match args with
- | [cexp; szexp] -> (
- try
- let sz = eval_array_size env szexp in
- match rec_eval_const cexp with
- | [cst] ->
- let atab = Array.make sz cst in
- [ Array_const_eff (atab, type_of_const_eff cst) ]
- | x ->
- raise (EvalConst_error("array of tuple not allowed"))
- with
- EvalArray_error msg -> raise(EvalConst_error msg)
- )
- | _ -> raise(EvalConst_error
- (sprintf "arity error: 2 expected instead of %d"
- (List.length args)))
- )
- | CONCAT_n -> (
- let ops = (List.map rec_eval_const args) in
- match ops with
- | [[Array_const_eff (v0, t0)];
- [Array_const_eff (v1, t1)]] -> (
- if(t0 = t1) then
- [Array_const_eff (Array.append v0 v1, t0)]
- else
- raise(EvalConst_error(
- sprintf
- "\n*** type combination error, can't concat %s with %s"
- (LicDump.string_of_type_eff(t0))
- (LicDump.string_of_type_eff(t1))
- ))
- )
- | [_;_] ->
- raise(EvalConst_error(
- "type combination error, array type expected"))
- | _ -> raise(EvalConst_error
- (sprintf "arity error: 2 expected instead of %d"
- (List.length ops)))
- )
- | ARRAY_n -> (
- let ops = (List.map rec_eval_const args) in
- [make_array_const (Array.of_list ops)]
- )
- | ARRAY_ACCES_n ix -> (
- let effargs = List.flatten (List.map rec_eval_const args) in
- match effargs with
- | [Array_const_eff (elts, typelts)] -> (
- try
- let sz = Array.length elts in
- let effix = eval_array_index env ix sz lxm in
- [Array.get elts effix ]
- with EvalArray_error msg -> raise(EvalConst_error msg)
- )
- | _ -> type_error_const effargs "some array"
- )
- | ARRAY_SLICE_n sl -> (
- let (elts, typelts) =
- match List.flatten (List.map rec_eval_const args) with
- | [Array_const_eff (l, t)] -> (l, t)
- | x -> type_error_const x "some array"
- in
- (* on en déduit la taille du tableau *)
- let sz = Array.length elts in
- (* évalue la slice *)
- try
- let sliceff = eval_array_slice env sl sz lxm in
- make_slice_const elts typelts sliceff
- with
- EvalArray_error msg -> raise(EvalConst_error msg)
- )
+ (posop : by_pos_op) (* l'operateur *)
+ (lxm : Lxm.t) (* source de l'opérateur *)
+ (args : val_exp list) (* arguments *)
+ = (
+ match (posop) with
+ (* capte les idents de constantes *)
+ IDENT_n id -> (
+ (* 2007-07 on interdit les externes *)
+ match (env.id2const id lxm) with
+ | Extern_const_eff(_,_, Some const_eff) -> [const_eff]
+ | Extern_const_eff(_,_,None) ->
+ raise (EvalConst_error(
+ sprintf "\n*** cannot access this abstract constant value"))
+ | x -> [ x ]
+ )
+ (* opérateur lazzy *)
+ | WITH_n(a0,a1,a2) -> (
+ match (rec_eval_const a0) with
+ [ Bool_const_eff true] -> rec_eval_const a1
+ | [ Bool_const_eff false] -> rec_eval_const a2
+ | x -> type_error_const x "bool"
+ )
+ (* mettre à plat la liste des args *)
+ | TUPLE_n -> ( List.flatten (List.map rec_eval_const args))
+ (* les tableaux de tuples sont interdits *)
+ | HAT_n -> (
+ match args with
+ | [cexp; szexp] -> (
+ try
+ let sz = eval_array_size env szexp in
+ match rec_eval_const cexp with
+ | [cst] ->
+ let atab = Array.make sz cst in
+ [ Array_const_eff (atab, type_of_const_eff cst) ]
+ | x ->
+ raise (EvalConst_error("array of tuple not allowed"))
+ with
+ EvalArray_error msg -> raise(EvalConst_error msg)
+ )
+ | _ -> raise(EvalConst_error
+ (sprintf "arity error: 2 expected instead of %d"
+ (List.length args)))
+ )
+ | CONCAT_n -> (
+ let ops = (List.map rec_eval_const args) in
+ match ops with
+ | [[Array_const_eff (v0, t0)];
+ [Array_const_eff (v1, t1)]] -> (
+ if(t0 = t1) then
+ [Array_const_eff (Array.append v0 v1, t0)]
+ else
+ raise(EvalConst_error(
+ sprintf
+ "\n*** type combination error, can't concat %s with %s"
+ (LicDump.string_of_type_eff(t0))
+ (LicDump.string_of_type_eff(t1))
+ ))
+ )
+ | [_;_] ->
+ raise(EvalConst_error(
+ "type combination error, array type expected"))
+ | _ -> raise(EvalConst_error
+ (sprintf "arity error: 2 expected instead of %d"
+ (List.length ops)))
+ )
+ | ARRAY_n -> (
+ let ops = (List.map rec_eval_const args) in
+ [make_array_const (Array.of_list ops)]
+ )
+ | ARRAY_ACCES_n ix -> (
+ let effargs = List.flatten (List.map rec_eval_const args) in
+ match effargs with
+ | [Array_const_eff (elts, typelts)] -> (
+ try
+ let sz = Array.length elts in
+ let effix = eval_array_index env ix sz lxm in
+ [Array.get elts effix ]
+ with EvalArray_error msg -> raise(EvalConst_error msg)
+ )
+ | _ -> type_error_const effargs "some array"
+ )
+ | ARRAY_SLICE_n sl -> (
+ let (elts, typelts) =
+ match List.flatten (List.map rec_eval_const args) with
+ | [Array_const_eff (l, t)] -> (l, t)
+ | x -> type_error_const x "some array"
+ in
+ (* on en déduit la taille du tableau *)
+ let sz = Array.length elts in
+ (* évalue la slice *)
+ try
+ let sliceff = eval_array_slice env sl sz lxm in
+ make_slice_const elts typelts sliceff
+ with
+ EvalArray_error msg -> raise(EvalConst_error msg)
+ )
- | STRUCT_ACCESS_n fid ->
- let ceff_list = List.flatten (List.map rec_eval_const args) in
- (match ceff_list with
- | [Struct_const_eff (flst, typ)] -> (
- try [(List.assoc fid flst)]
- with Not_found ->
- raise (EvalConst_error
- (Printf.sprintf "%s is not a field of struct %s"
- (Ident.to_string fid)
- (LicDump.string_of_type_eff(typ))))
- )
- | [x] -> type_error_const [x] "struct type"
- | x -> arity_error_const x "1"
- )
+ | STRUCT_ACCESS_n fid ->
+ let ceff_list = List.flatten (List.map rec_eval_const args) in
+ (match ceff_list with
+ | [Struct_const_eff (flst, typ)] -> (
+ try [(List.assoc fid flst)]
+ with Not_found ->
+ raise (EvalConst_error
+ (Printf.sprintf "%s is not a field of struct %s"
+ (Ident.to_string fid)
+ (LicDump.string_of_type_eff(typ))))
+ )
+ | [x] -> type_error_const [x] "struct type"
+ | x -> arity_error_const x "1"
+ )
- | CALL_n _ -> not_evaluable_construct "node call"
- | MERGE_n _ -> not_evaluable_construct "merge"
- | WHEN_n -> not_evaluable_construct "when"
- | FBY_n -> not_evaluable_construct "fby"
- | ARROW_n -> not_evaluable_construct "->"
- | CURRENT_n -> not_evaluable_construct "current"
- | PRE_n -> not_evaluable_construct "pre"
+ | CALL_n _ -> not_evaluable_construct "node call"
+ | MERGE_n _ -> not_evaluable_construct "merge"
+ | WHEN_n -> not_evaluable_construct "when"
+ | FBY_n -> not_evaluable_construct "fby"
+ | ARROW_n -> not_evaluable_construct "->"
+ | CURRENT_n -> not_evaluable_construct "current"
+ | PRE_n -> not_evaluable_construct "pre"
- | Predef(op,sargs)
- ->
- if sargs = [] then
- let effargs = (List.map rec_eval_const args) in
- PredefEvalConst.f op lxm [] effargs
- else
- (* Well, it migth be possible after all... TODO *)
- not_evaluable_construct (op2string op)
-
-
- ) (* FIN DE : eval_by_pos_const *)
- (*-------------------------------------*)
- (* Fonction récursive secondaire *)
- (*-------------------------------------*)
- (* -> Eval. d'une expression spéciale *)
- (* "par nom" *)
- (*-------------------------------------*)
+ | Predef(op,sargs)
+ ->
+ if sargs = [] then
+ let effargs = (List.map rec_eval_const args) in
+ PredefEvalConst.f op lxm [] effargs
+ else
+ (* Well, it migth be possible after all... TODO *)
+ not_evaluable_construct (op2string op)
+
+
+ ) (* FIN DE : eval_by_pos_const *)
+ (*-------------------------------------*)
+ (* Fonction récursive secondaire *)
+ (*-------------------------------------*)
+ (* -> Eval. d'une expression spéciale *)
+ (* "par nom" *)
+ (*-------------------------------------*)
and eval_by_name_const
- (namop : by_name_op) (* l'operateur *)
- (lxm : Lxm.t) (* source de l'opérateur *)
- (namargs : (Ident.t srcflagged * val_exp) list) (* arguments *)
- = (
- match namop with
- | STRUCT_anonymous_n ->
- finish_me "anonymous struct";
- assert false
-
- | STRUCT_n opid -> (
- (* effet de bord : on tabule les param effectif *)
- let arg_tab = Hashtbl.create 50 in
- let treat_one_arg ((pid:Ident.t srcflagged), (pexp:val_exp)) =
- if
- (Hashtbl.mem arg_tab pid.it)
- then
- raise(EvalConst_error(
- sprintf
- "multiple definition of param %s in %s call"
- (Ident.to_string pid.it)
- (Ident.string_of_idref opid)))
- else
- let v = rec_eval_const pexp in
- match v with
- | [x] -> Hashtbl.add arg_tab pid.it (pid.src, x)
- | _ ->
- raise(
- EvalConst_error(
- sprintf
- "unexpected tuple value for param %s in %s call"
- (Ident.to_string pid.it)
- (Ident.string_of_idref opid)
- ))
- in
- List.iter treat_one_arg namargs ;
- (* pour l'instant, on ne traite que les constructions de struct *)
- try let teff = env.id2type opid lxm in
- [make_struct_const teff arg_tab]
- with _ ->
- raise(EvalConst_error(
- sprintf "struct type expected instead of %s"
- (Ident.string_of_idref opid)))
- )
- ) (* FIN DE : eval_by_name_const *)
- (*-------------------------------------*)
- (* Corps de la fonction principale *)
- (*-------------------------------------*)
+ (namop : by_name_op) (* l'operateur *)
+ (lxm : Lxm.t) (* source de l'opérateur *)
+ (namargs : (Ident.t srcflagged * val_exp) list) (* arguments *)
+ = (
+ match namop with
+ | STRUCT_anonymous_n ->
+ finish_me "anonymous struct";
+ assert false
+
+ | STRUCT_n opid -> (
+ (* effet de bord : on tabule les param effectif *)
+ let arg_tab = Hashtbl.create 50 in
+ let treat_one_arg ((pid:Ident.t srcflagged), (pexp:val_exp)) =
+ if
+ (Hashtbl.mem arg_tab pid.it)
+ then
+ raise(EvalConst_error(
+ sprintf
+ "multiple definition of param %s in %s call"
+ (Ident.to_string pid.it)
+ (Ident.string_of_idref opid)))
+ else
+ let v = rec_eval_const pexp in
+ match v with
+ | [x] -> Hashtbl.add arg_tab pid.it (pid.src, x)
+ | _ ->
+ raise(
+ EvalConst_error(
+ sprintf
+ "unexpected tuple value for param %s in %s call"
+ (Ident.to_string pid.it)
+ (Ident.string_of_idref opid)
+ ))
+ in
+ List.iter treat_one_arg namargs ;
+ (* pour l'instant, on ne traite que les constructions de struct *)
+ try let teff = env.id2type opid lxm in
+ [make_struct_const teff arg_tab]
+ with _ ->
+ raise(EvalConst_error(
+ sprintf "struct type expected instead of %s"
+ (Ident.string_of_idref opid)))
+ )
+ ) (* FIN DE : eval_by_name_const *)
+ (*-------------------------------------*)
+ (* Corps de la fonction principale *)
+ (*-------------------------------------*)
in
- rec_eval_const vexp
+ rec_eval_const vexp
) (* fin de f *)
(*---------------------------------------------------------------------
@@ -396,14 +396,14 @@ and (eval_array_size: id_solver -> val_exp -> int) =
fun id_solver szexp ->
match (f id_solver szexp) with
| [Int_const_eff sz] ->
- if (sz > 0) then sz else
- raise(EvalArray_error(sprintf "bad array size %d" sz))
+ if (sz > 0) then sz else
+ raise(EvalArray_error(sprintf "bad array size %d" sz))
| [x] ->
- raise(EvalArray_error(sprintf "bad array size, int expected but get %s"
- (LicDump.string_of_type_eff(type_of_const_eff x))))
+ raise(EvalArray_error(sprintf "bad array size, int expected but get %s"
+ (LicDump.string_of_type_eff(type_of_const_eff x))))
| _ ->
- raise(EvalArray_error(sprintf "bad array size, int expected, not a tuple"))
-
+ raise(EvalArray_error(sprintf "bad array size, int expected, not a tuple"))
+
(*---------------------------------------------------------------------
eval_array_index
-----------------------------------------------------------------------
@@ -427,28 +427,28 @@ and eval_array_index
try
(
match (f env ixexp) with
- | [Int_const_eff i]
- | [Extern_const_eff(_,_, Some (Int_const_eff i))] -> check_int i sz
- | [Extern_const_eff(id,_,None)] ->
- raise(EvalArray_error("The extern const " ^ (Ident.string_of_long id) ^
- " is abstract"))
- | [Extern_const_eff(_,_, Some x)]
- | [x] -> raise(EvalArray_error(sprintf
- "bad array index, int expected but get %s"
- (LicDump.string_of_type_eff(type_of_const_eff x)))
- )
- | _ -> raise(EvalArray_error(
- sprintf "bad array index, int expected but get a tuple"))
+ | [Int_const_eff i]
+ | [Extern_const_eff(_,_, Some (Int_const_eff i))] -> check_int i sz
+ | [Extern_const_eff(id,_,None)] ->
+ raise(EvalArray_error("The extern const " ^ (Ident.string_of_long id) ^
+ " is abstract"))
+ | [Extern_const_eff(_,_, Some x)]
+ | [x] -> raise(EvalArray_error(sprintf
+ "bad array index, int expected but get %s"
+ (LicDump.string_of_type_eff(type_of_const_eff x)))
+ )
+ | _ -> raise(EvalArray_error(
+ sprintf "bad array index, int expected but get a tuple"))
)
with
EvalArray_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
-
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+
and check_int i sz =
if ((i >= 0) && (i < sz)) then i
else raise(EvalArray_error(
- sprintf "array index %d out of bounds 0..%d" i (sz-1)))
+ sprintf "array index %d out of bounds 0..%d" i (sz-1)))
(*---------------------------------------------------------------------
eval_array_slice
@@ -473,42 +473,42 @@ and eval_array_slice (env : id_solver) (sl : slice_info) (sz : int) (lxm : Lxm.t
let last_ix = eval_array_index env sl.si_last sz lxm in
let step =
match sl.si_step with
- | Some stepexp -> (
- match (f env stepexp) with
- | [Int_const_eff s] -> s (* ok *)
- | [x] -> raise(EvalArray_error(
- sprintf "bad array step, int expected but get %s"
- (LicDump.string_of_type_eff (type_of_const_eff x))))
- | _ -> raise(EvalArray_error(
- sprintf "bad array step, int expected but get a tuple"))
- )
- | None -> if (first_ix <= last_ix) then 1 else -1
+ | Some stepexp -> (
+ match (f env stepexp) with
+ | [Int_const_eff s] -> s (* ok *)
+ | [x] -> raise(EvalArray_error(
+ sprintf "bad array step, int expected but get %s"
+ (LicDump.string_of_type_eff (type_of_const_eff x))))
+ | _ -> raise(EvalArray_error(
+ sprintf "bad array step, int expected but get a tuple"))
+ )
+ | None -> if (first_ix <= last_ix) then 1 else -1
in
if
- (step = 0)
- || ((step > 0) && (first_ix > last_ix))
- || ((step < 0) && (first_ix < last_ix))
+ (step = 0)
+ || ((step > 0) && (first_ix > last_ix))
+ || ((step < 0) && (first_ix < last_ix))
then
- let msg = sprintf "bad array slice [%d..%d] step %d" first_ix last_ix step in
- raise (EvalArray_error msg)
+ let msg = sprintf "bad array slice [%d..%d] step %d" first_ix last_ix step in
+ raise (EvalArray_error msg)
else
- (* index relatif du dernier *)
- let last_rel = abs (last_ix-first_ix) in
- let abs_step = abs step in
- (* le dernier est-il pris dans la tranche ? *)
- if ((last_rel mod abs_step) <> 0) then
- warning lxm (sprintf "last index out of slice [%d..%d step %d]"
- first_ix last_ix step);
- let width = 1 + last_rel/abs_step in
- (* on force le dernier a être dans la tranche *)
- let real_last_ix = first_ix + (width-1) * step in
- (* (first_ix,last_ix,step,width) *)
- {
- se_first = first_ix;
- se_last = real_last_ix;
- se_step = step;
- se_width = width
- }
+ (* index relatif du dernier *)
+ let last_rel = abs (last_ix-first_ix) in
+ let abs_step = abs step in
+ (* le dernier est-il pris dans la tranche ? *)
+ if ((last_rel mod abs_step) <> 0) then
+ warning lxm (sprintf "last index out of slice [%d..%d step %d]"
+ first_ix last_ix step);
+ let width = 1 + last_rel/abs_step in
+ (* on force le dernier a être dans la tranche *)
+ let real_last_ix = first_ix + (width-1) * step in
+ (* (first_ix,last_ix,step,width) *)
+ {
+ se_first = first_ix;
+ se_last = real_last_ix;
+ se_step = step;
+ se_width = width
+ }
with
EvalArray_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
diff --git a/src/evalType.ml b/src/evalType.ml
index 666da7c0..5211210e 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 28/08/2008 (at 09:19) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:27) by Erwan Jahier> *)
open Predef
@@ -35,14 +35,14 @@ let rec (f : id_solver -> val_exp_eff -> type_eff list) =
let res =
match ve with
| CallByPosEff ({it=posop; src=lxm}, OperEff args) -> (
- try eval_by_pos_type id_solver posop lxm args
- with EvalType_error msg ->
- raise (Compile_error(lxm, "type error: "^msg))
- )
+ try eval_by_pos_type id_solver posop lxm args
+ with EvalType_error msg ->
+ raise (Compile_error(lxm, "type error: "^msg))
+ )
| CallByNameEff ({it=nmop; src=lxm}, nmargs ) ->
- try eval_by_name_type id_solver nmop lxm nmargs
- with EvalConst_error msg ->
- raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
+ try eval_by_name_type id_solver nmop lxm nmargs
+ with EvalConst_error msg ->
+ raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
in
tabulate_res ve res;
res
@@ -71,117 +71,117 @@ and (eval_by_pos_type :
res
)
| CALL_eff node_exp_eff ->
- let lti = List.map (fun v -> v.var_type_eff) node_exp_eff.it.inlist_eff in
- let lto = List.map (fun v -> v.var_type_eff) node_exp_eff.it.outlist_eff in
- let t_args = List.flatten (List.map (f id_solver) args) in
- let llti = List.length lti and lt_args = List.length t_args in
- if llti <> lt_args then
- raise (EvalType_error(
- sprintf
- "\n*** arity error: %d argument(s) are expected, whereas %d is/are provided"
- llti lt_args))
- else
- (match UnifyType.f lti t_args with
- | UnifyType.Equal -> lto
- | UnifyType.Unif subst -> List.map (subst_type subst) lto
- | UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
- )
-
+ let lti = List.map (fun v -> v.var_type_eff) node_exp_eff.it.inlist_eff in
+ let lto = List.map (fun v -> v.var_type_eff) node_exp_eff.it.outlist_eff in
+ let t_args = List.flatten (List.map (f id_solver) args) in
+ let llti = List.length lti and lt_args = List.length t_args in
+ if llti <> lt_args then
+ raise (EvalType_error(
+ sprintf
+ "\n*** arity error: %d argument(s) are expected, whereas %d is/are provided"
+ llti lt_args))
+ else
+ (match UnifyType.f lti t_args with
+ | UnifyType.Equal -> lto
+ | UnifyType.Unif subst -> List.map (subst_type subst) lto
+ | UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
+ )
+
| CONST_eff (id,_) -> [type_of_const_eff (id_solver.id2const id lxm)]
| IDENT_eff id -> (
- (* [id] migth be a constant, but also a variable *)
- try [type_of_const_eff (id_solver.id2const id lxm)]
- with _ -> [(id_solver.id2var id lxm).var_type_eff]
- )
+ (* [id] migth be a constant, but also a variable *)
+ try [type_of_const_eff (id_solver.id2const id lxm)]
+ with _ -> [(id_solver.id2var id lxm).var_type_eff]
+ )
| WITH_eff(ve) -> f id_solver ve
| TUPLE_eff -> List.flatten (List.map (f id_solver) args)
| CONCAT_eff -> (
- match List.map (f id_solver) args with
- | [[Array_type_eff (teff0, size0)]; [Array_type_eff (teff1, size1)]] ->
- let teff =
- match UnifyType.f [teff0] [teff1] with
- | UnifyType.Equal -> teff1
- | UnifyType.Unif subst -> subst_type subst teff1
- | UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
- in
- [Array_type_eff (teff, size0+size1)]
- | _ ->
- raise(EvalType_error(sprintf "arity error: 2 expected instead of %d"
- (List.length args)))
- )
+ match List.map (f id_solver) args with
+ | [[Array_type_eff (teff0, size0)]; [Array_type_eff (teff1, size1)]] ->
+ let teff =
+ match UnifyType.f [teff0] [teff1] with
+ | UnifyType.Equal -> teff1
+ | UnifyType.Unif subst -> subst_type subst teff1
+ | UnifyType.Ko msg -> raise (Compile_error(lxm, msg))
+ in
+ [Array_type_eff (teff, size0+size1)]
+ | _ ->
+ raise(EvalType_error(sprintf "arity error: 2 expected instead of %d"
+ (List.length args)))
+ )
| STRUCT_ACCESS_eff fid -> (
- let type_args_eff = List.flatten (List.map (f id_solver) args) in
- match type_args_eff with
- | [Struct_type_eff (name, fl)] -> (
- try [fst (List.assoc fid fl)]
- with Not_found ->
- raise (EvalType_error
- (Printf.sprintf "%s is not a field of struct %s"
- (Ident.to_string fid)
- (LicDump.string_of_type_eff(List.hd type_args_eff))))
- )
- | [x] -> type_error [x] "struct type"
- | x -> arity_error x "1"
- )
+ let type_args_eff = List.flatten (List.map (f id_solver) args) in
+ match type_args_eff with
+ | [Struct_type_eff (name, fl)] -> (
+ try [fst (List.assoc fid fl)]
+ with Not_found ->
+ raise (EvalType_error
+ (Printf.sprintf "%s is not a field of struct %s"
+ (Ident.to_string fid)
+ (LicDump.string_of_type_eff(List.hd type_args_eff))))
+ )
+ | [x] -> type_error [x] "struct type"
+ | x -> arity_error x "1"
+ )
| ARRAY_ACCES_eff (_, teff) -> [teff] (* XXX check args type! *)
| ARRAY_SLICE_eff (sieff,teff) ->
- [Array_type_eff(teff, sieff.se_width)]
+ [Array_type_eff(teff, sieff.se_width)]
| HAT_eff(size,ceff) ->
- let teff_list = f id_solver ceff in
- List.map (fun teff -> Array_type_eff(teff, size)) teff_list
-
+ let teff_list = f id_solver ceff in
+ List.map (fun teff -> Array_type_eff(teff, size)) teff_list
+
| ARRAY_eff ->
- (* check that args are of the same type *)
- let type_args_eff = (List.map (f id_solver) args) in
- let teff_elt =
- List.fold_left
- (fun acc teff ->
- match acc with
- | [] -> teff
- | [sacc] -> if acc = teff then acc else
- raise(EvalType_error(
- "all array elements should be of the same type"))
- | _ -> assert false
- )
- []
- type_args_eff
- in
- assert (List.length teff_elt = 1);
- [Array_type_eff(List.hd teff_elt, List.length args)]
+ (* check that args are of the same type *)
+ let type_args_eff = (List.map (f id_solver) args) in
+ let teff_elt =
+ List.fold_left
+ (fun acc teff ->
+ match acc with
+ | [] -> teff
+ | [sacc] -> if acc = teff then acc else
+ raise(EvalType_error(
+ "all array elements should be of the same type"))
+ | _ -> assert false
+ )
+ []
+ type_args_eff
+ in
+ assert (List.length teff_elt = 1);
+ [Array_type_eff(List.hd teff_elt, List.length args)]
| WHENOT_eff _
| WHEN_eff _ -> (
- let type_args_eff = List.map (f id_solver) args in
- match type_args_eff with
- | [teff; [Bool_type_eff]]
- | [teff; [Enum_type_eff _] ] -> teff
+ let type_args_eff = List.map (f id_solver) args in
+ match type_args_eff with
+ | [teff; [Bool_type_eff]]
+ | [teff; [Enum_type_eff _] ] -> teff
| [_;teff] ->
let msg ="the type of a clock cannot be " ^
(String.concat "," (List.map LicDump.string_of_type_eff teff) )
in
raise(EvalType_error(msg))
- | _ -> raise(EvalType_error("arity error (2 args expected)"))
- )
+ | _ -> raise(EvalType_error("arity error (2 args expected)"))
+ )
| ARROW_eff
| FBY_eff -> (
- let type_args_eff = List.map (f id_solver) args in
- match type_args_eff with
- | [init; teff] -> if init = teff then teff else
- raise(EvalType_error("type mismatch. "))
- | _ -> raise(EvalType_error("arity error (2 args expected)"))
- )
+ let type_args_eff = List.map (f id_solver) args in
+ match type_args_eff with
+ | [init; teff] -> if init = teff then teff else
+ raise(EvalType_error("type mismatch. "))
+ | _ -> raise(EvalType_error("arity error (2 args expected)"))
+ )
| CURRENT_eff
| PRE_eff -> (
- let type_args_eff = List.map (f id_solver) args in
- match type_args_eff with
- | [teff] -> teff
- | _ -> raise(EvalType_error("arity error (1 arg expected)"))
- )
+ let type_args_eff = List.map (f id_solver) args in
+ match type_args_eff with
+ | [teff] -> teff
+ | _ -> raise(EvalType_error("arity error (1 arg expected)"))
+ )
| MERGE_eff _ -> finish_me "merge"; assert false
@@ -191,17 +191,17 @@ and (eval_by_name_type : id_solver -> by_name_op_eff -> Lxm.t ->
fun id_solver namop lxm namargs ->
match namop with
| STRUCT_anonymous_eff ->
- (* ??? comment faire ici pour recuperer son type ???
- il faut que je recherche à l'aide des noms de champs
- le type structure qui va bien !
-
- - creer une table [liste des noms de champs -> ident de type structure] ?
- - rajouter dans la table a sa creation une entree dont le nom
- est composé du nom des champs ?
- *)
- finish_me "anonymous struct not yet supported";
- assert false
- (* failwith "Finish me: anonymous struct not yet supported" *)
+ (* ??? comment faire ici pour recuperer son type ???
+ il faut que je recherche à l'aide des noms de champs
+ le type structure qui va bien !
+
+ - creer une table [liste des noms de champs -> ident de type structure] ?
+ - rajouter dans la table a sa creation une entree dont le nom
+ est composé du nom des champs ?
+ *)
+ finish_me "anonymous struct not yet supported";
+ assert false
+ (* failwith "Finish me: anonymous struct not yet supported" *)
| STRUCT_eff (pn,opid) -> [id_solver.id2type opid lxm]
diff --git a/src/expandPack.ml b/src/expandPack.ml
index 454359e9..f5822ddf 100644
--- a/src/expandPack.ml
+++ b/src/expandPack.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 03/06/2008 (at 11:34) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:27) by Erwan Jahier> *)
open Lxm
open SyntaxTree
@@ -12,160 +12,160 @@ let (doit:
SyntaxTree.pack_given) =
fun mtab pdata -> (
match (pdata.it.pa_def) with
- PackGiven pg -> pg
- (* on garde tel-quel ... *)
-
+ PackGiven pg -> pg
+ (* on garde tel-quel ... *)
+
| PackInstance pi -> (
- (* recherche du modèle *)
- let mi = try Hashtbl.find mtab pi.pi_model
- with Not_found ->
- let msg = Printf.sprintf "bad pack instance: model %s undeclared"
- (Ident.to_string pi.pi_model)
- in
- raise ( Compile_error (pdata.src, msg))
- in
- (*-----------INIT-----------------------------------*)
- (* On part du packbody du modèle, dont on duplique les tables :*)
- let ctab = Hashtbl.copy mi.it.mo_body.pk_const_table in
- let ttab = Hashtbl.copy mi.it.mo_body.pk_type_table in
- let otab = Hashtbl.copy mi.it.mo_body.pk_node_table in
- (* liste des nouveaux define ... *)
- let newdefs = ref [] in
- (* liste des nouveaux provides ... *)
- let newprov = ref [] in
- (* On met en correspondance les pi_args avec les mo_needs *)
- let args = pi.pi_args in
- let pars = mi.it.mo_needs in
- (*--------------------------------------------------*)
+ (* recherche du modèle *)
+ let mi = try Hashtbl.find mtab pi.pi_model
+ with Not_found ->
+ let msg = Printf.sprintf "bad pack instance: model %s undeclared"
+ (Ident.to_string pi.pi_model)
+ in
+ raise ( Compile_error (pdata.src, msg))
+ in
+ (*-----------INIT-----------------------------------*)
+ (* On part du packbody du modèle, dont on duplique les tables :*)
+ let ctab = Hashtbl.copy mi.it.mo_body.pk_const_table in
+ let ttab = Hashtbl.copy mi.it.mo_body.pk_type_table in
+ let otab = Hashtbl.copy mi.it.mo_body.pk_node_table in
+ (* liste des nouveaux define ... *)
+ let newdefs = ref [] in
+ (* liste des nouveaux provides ... *)
+ let newprov = ref [] in
+ (* On met en correspondance les pi_args avec les mo_needs *)
+ let args = pi.pi_args in
+ let pars = mi.it.mo_needs in
+ (*--------------------------------------------------*)
- (* la fonction qui traite un couple ... *)
- let (check_arg : static_param srcflagged -> static_arg srcflagged -> unit) =
- fun param arg ->
- (* message d'erreur standard *)
- let instance_error () =
- let msg = Printf.sprintf
- "bad argument in package instance: %s" (Lxm.details param.src)
- in
- raise (Compile_error (arg.src, msg))
- in
- (* on a soit un ident, à checker plus tard, soit une
- expression de la bonne nature *)
- match (param.it) with
- | StaticParamType s -> (
- let te = match (arg.it) with
- StaticArgIdent idr ->
- Lxm.flagit (Named_type_exp idr) arg.src
- | StaticArgType x -> x
- | _ -> instance_error ()
- in
- let ti = AliasedType (s, te) in
- let x = Lxm.flagit (TypeInfo ti) param.src in
- newprov := x::!newprov ;
- let y = Lxm.flagit ti param.src in
- put_in_tab "type" ttab s y ;
- newdefs := (TypeItem s)::!newdefs
- )
- | StaticParamConst (s,te) -> (
- let ce = match (arg.it) with
- | StaticArgIdent idr ->
- ParserUtils.leafexp arg.src (IDENT_n idr)
- | StaticArgConst x -> x
- | _ -> instance_error ()
- in
- let ci = DefinedConst (s, Some te, ce) in
- let x = Lxm.flagit (ConstInfo ci) param.src in
- newprov := x::!newprov ;
- let y = Lxm.flagit ci param.src in
- put_in_tab "const" ctab s y ;
- newdefs := (ConstItem s)::!newdefs
- )
- | StaticParamNode (s, inl, outl, has_memory) -> (
- let by_pos_op = match (arg.it) with
- | StaticArgIdent idr ->
- CALL_n(Lxm.flagit ((idr,[])) arg.src)
- | StaticArgNode by_pos_op -> by_pos_op
- | _ -> instance_error ()
- in
- let sparams = [] in
- let ni = {
- name = s;
- static_params = sparams;
- vars = Some (ParserUtils.build_node_var inl outl None);
- def = Alias (flagit by_pos_op arg.src);
- has_mem = has_memory;
- is_safe = true;
- }
- in
- let x = Lxm.flagit (NodeInfo ni) param.src in
- newprov := x::!newprov ;
- let y = Lxm.flagit ni param.src in
- put_in_tab "node" otab s y ;
- newdefs := (NodeItem (s,sparams))::!newdefs
- )
- (* check_arg *)
- in
- let (sargs_pack : Ident.pack_name srcflagged list) =
- List.fold_left
- (fun acc arg ->
- (match arg.it with
- | StaticArgIdent(idref) ->
- (match Ident.pack_of_idref idref with
- | None -> acc
- | Some p ->
- let p_flagged = Lxm.flagit p arg.src in
- if List.mem p_flagged acc then acc else p_flagged::acc
- )
- | _ -> acc
- )
- )
- []
- args
- in
- let pars_nb = string_of_int (List.length pars)
- and args_nb = string_of_int (List.length args) in
- try (
- (*------------TRAITEMENT---------------------------------*)
- if (pars_nb <> args_nb) then
- raise(Compile_error
- (pdata.src,
- ("\n*** " ^pars_nb ^
- " arguments are expected, but "^args_nb^
- " were provided when defining package "^
- (Ident.pack_name_to_string pdata.it.pa_name)
- )));
- List.iter2 check_arg pars args;
- (* on fabrique un pack_given valide avec les infos récoltées *)
- let body = {
- pk_const_table = ctab ;
- pk_type_table = ttab ;
- pk_node_table = otab ;
- pk_def_list = List.append
- (mi.it.mo_body.pk_def_list)
- (List.rev !newdefs)
- } in
- (* les provides du modèle + les nouveaux de newprov *)
- (* SAUF SI ON EXPORTE DEJA TOUT ! *)
- let prov = match (mi.it.mo_provides) with
- Some l -> (
- Some (List.append l (List.rev !newprov))
- )
- | None -> None
- in
- let pg = {
- (* les uses du modèle + les packages utilisés par les arg statiques *)
- pg_uses = mi.it.mo_uses @ sargs_pack;
- pg_provides = prov ;
- pg_body = body ;
- } in
- pg
- ) with Invalid_argument _ -> (
- let msg = Printf.sprintf
- "bad pack instance: %d args provided while model %s has %d params"
- (List.length args)
- (Ident.to_string pi.pi_model)
- (List.length pars)
- in
- raise ( Compile_error (pdata.src, msg))
- )
- )
+ (* la fonction qui traite un couple ... *)
+ let (check_arg : static_param srcflagged -> static_arg srcflagged -> unit) =
+ fun param arg ->
+ (* message d'erreur standard *)
+ let instance_error () =
+ let msg = Printf.sprintf
+ "bad argument in package instance: %s" (Lxm.details param.src)
+ in
+ raise (Compile_error (arg.src, msg))
+ in
+ (* on a soit un ident, à checker plus tard, soit une
+ expression de la bonne nature *)
+ match (param.it) with
+ | StaticParamType s -> (
+ let te = match (arg.it) with
+ StaticArgIdent idr ->
+ Lxm.flagit (Named_type_exp idr) arg.src
+ | StaticArgType x -> x
+ | _ -> instance_error ()
+ in
+ let ti = AliasedType (s, te) in
+ let x = Lxm.flagit (TypeInfo ti) param.src in
+ newprov := x::!newprov ;
+ let y = Lxm.flagit ti param.src in
+ put_in_tab "type" ttab s y ;
+ newdefs := (TypeItem s)::!newdefs
+ )
+ | StaticParamConst (s,te) -> (
+ let ce = match (arg.it) with
+ | StaticArgIdent idr ->
+ ParserUtils.leafexp arg.src (IDENT_n idr)
+ | StaticArgConst x -> x
+ | _ -> instance_error ()
+ in
+ let ci = DefinedConst (s, Some te, ce) in
+ let x = Lxm.flagit (ConstInfo ci) param.src in
+ newprov := x::!newprov ;
+ let y = Lxm.flagit ci param.src in
+ put_in_tab "const" ctab s y ;
+ newdefs := (ConstItem s)::!newdefs
+ )
+ | StaticParamNode (s, inl, outl, has_memory) -> (
+ let by_pos_op = match (arg.it) with
+ | StaticArgIdent idr ->
+ CALL_n(Lxm.flagit ((idr,[])) arg.src)
+ | StaticArgNode by_pos_op -> by_pos_op
+ | _ -> instance_error ()
+ in
+ let sparams = [] in
+ let ni = {
+ name = s;
+ static_params = sparams;
+ vars = Some (ParserUtils.build_node_var inl outl None);
+ def = Alias (flagit by_pos_op arg.src);
+ has_mem = has_memory;
+ is_safe = true;
+ }
+ in
+ let x = Lxm.flagit (NodeInfo ni) param.src in
+ newprov := x::!newprov ;
+ let y = Lxm.flagit ni param.src in
+ put_in_tab "node" otab s y ;
+ newdefs := (NodeItem (s,sparams))::!newdefs
+ )
+ (* check_arg *)
+ in
+ let (sargs_pack : Ident.pack_name srcflagged list) =
+ List.fold_left
+ (fun acc arg ->
+ (match arg.it with
+ | StaticArgIdent(idref) ->
+ (match Ident.pack_of_idref idref with
+ | None -> acc
+ | Some p ->
+ let p_flagged = Lxm.flagit p arg.src in
+ if List.mem p_flagged acc then acc else p_flagged::acc
+ )
+ | _ -> acc
+ )
+ )
+ []
+ args
+ in
+ let pars_nb = string_of_int (List.length pars)
+ and args_nb = string_of_int (List.length args) in
+ try (
+ (*------------TRAITEMENT---------------------------------*)
+ if (pars_nb <> args_nb) then
+ raise(Compile_error
+ (pdata.src,
+ ("\n*** " ^pars_nb ^
+ " arguments are expected, but "^args_nb^
+ " were provided when defining package "^
+ (Ident.pack_name_to_string pdata.it.pa_name)
+ )));
+ List.iter2 check_arg pars args;
+ (* on fabrique un pack_given valide avec les infos récoltées *)
+ let body = {
+ pk_const_table = ctab ;
+ pk_type_table = ttab ;
+ pk_node_table = otab ;
+ pk_def_list = List.append
+ (mi.it.mo_body.pk_def_list)
+ (List.rev !newdefs)
+ } in
+ (* les provides du modèle + les nouveaux de newprov *)
+ (* SAUF SI ON EXPORTE DEJA TOUT ! *)
+ let prov = match (mi.it.mo_provides) with
+ Some l -> (
+ Some (List.append l (List.rev !newprov))
+ )
+ | None -> None
+ in
+ let pg = {
+ (* les uses du modèle + les packages utilisés par les arg statiques *)
+ pg_uses = mi.it.mo_uses @ sargs_pack;
+ pg_provides = prov ;
+ pg_body = body ;
+ } in
+ pg
+ ) with Invalid_argument _ -> (
+ let msg = Printf.sprintf
+ "bad pack instance: %d args provided while model %s has %d params"
+ (List.length args)
+ (Ident.to_string pi.pi_model)
+ (List.length pars)
+ in
+ raise ( Compile_error (pdata.src, msg))
+ )
+ )
)
diff --git a/src/getEff.ml b/src/getEff.ml
index 06d2e31e..7ea8a6f7 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/08/2008 (at 15:55) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:27) by Erwan Jahier> *)
open Lxm
@@ -14,20 +14,20 @@ exception GetEffType_error of string
(* exported *)
let rec (typ:CompiledData.id_solver -> SyntaxTreeCore.type_exp ->
- CompiledData.type_eff)=
+ CompiledData.type_eff)=
fun env texp ->
try (
match texp.it with
- | Bool_type_exp -> Bool_type_eff
- | Int_type_exp -> Int_type_eff
- | Real_type_exp -> Real_type_eff
- | Named_type_exp s -> env.id2type s texp.src
- | Array_type_exp (elt_texp, szexp) ->
- let elt_teff = typ env elt_texp in
- try
- let sz = EvalConst.eval_array_size env szexp in
- Array_type_eff (elt_teff, sz)
- with EvalConst.EvalArray_error msg -> raise(GetEffType_error msg)
+ | Bool_type_exp -> Bool_type_eff
+ | Int_type_exp -> Int_type_eff
+ | Real_type_exp -> Real_type_eff
+ | Named_type_exp s -> env.id2type s texp.src
+ | Array_type_exp (elt_texp, szexp) ->
+ let elt_teff = typ env elt_texp in
+ try
+ let sz = EvalConst.eval_array_size env szexp in
+ Array_type_eff (elt_teff, sz)
+ with EvalConst.EvalArray_error msg -> raise(GetEffType_error msg)
)
with GetEffType_error msg ->
raise (Compile_error(texp.src, "can't eval type: "^msg))
@@ -38,8 +38,8 @@ let rec (clock : CompiledData.id_solver -> var_info -> CompiledData.clock_eff)=
match v.var_clock with
| Base -> On(v.var_name,BaseEff)
| NamedClock id ->
- let id_v = id_solver.id2var (Ident.to_idref id.it) id.src in
- On(v.var_name, id_v.var_clock_eff)
+ let id_v = id_solver.id2var (Ident.to_idref id.it) id.src in
+ On(v.var_name, id_v.var_clock_eff)
(******************************************************************************)
@@ -50,25 +50,25 @@ and (type_check_equation: id_solver -> eq_info srcflagged -> left_eff list ->
let lpl_teff = List.map type_eff_of_left_eff lpl_eff in
let right_part = EvalType.f id_solver ve_eff in
if (List.length lpl_teff <> List.length right_part) then
- raise (Compile_error(eq_info.src,
- "tuple size error: \n*** the tuple size is\n***\t"^
- (string_of_int (List.length lpl_teff)) ^
- " for the left-hand-side, and \n***\t" ^
- (string_of_int (List.length right_part)) ^
- " for the right-hand-side"))
+ raise (Compile_error(eq_info.src,
+ "tuple size error: \n*** the tuple size is\n***\t"^
+ (string_of_int (List.length lpl_teff)) ^
+ " for the left-hand-side, and \n***\t" ^
+ (string_of_int (List.length right_part)) ^
+ " for the right-hand-side"))
else
- List.iter2
- (fun le re ->
- if le <> re then
- let msg = "type mismatch: \n***\t'"
- ^ (LicDump.string_of_type_eff le) ^
- "' (left-hand-side) \n*** is not compatible with \n***\t'"
- ^ (LicDump.string_of_type_eff re) ^ "' (right-hand-side)"
- in
- raise (Compile_error(eq_info.src, msg))
- )
- lpl_teff
- right_part
+ List.iter2
+ (fun le re ->
+ if le <> re then
+ let msg = "type mismatch: \n***\t'"
+ ^ (LicDump.string_of_type_eff le) ^
+ "' (left-hand-side) \n*** is not compatible with \n***\t'"
+ ^ (LicDump.string_of_type_eff re) ^ "' (right-hand-side)"
+ in
+ raise (Compile_error(eq_info.src, msg))
+ )
+ lpl_teff
+ right_part
(* Checks that the left part has the same clock as the right one. *)
and (clock_check_equation:id_solver -> eq_info srcflagged -> left_eff list ->
@@ -89,18 +89,18 @@ let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
(* exported *)
let rec (node : CompiledData.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
- CompiledData.node_exp_eff) =
+ CompiledData.node_exp_eff) =
fun id_solver { src = lxm; it=(idref, static_args) } ->
let static_params = get_static_params_from_idref id_solver.symbols lxm idref in
let static_args_eff =
assert(List.length static_params = List.length static_args);
List.map2 (check_static_arg id_solver)
- static_params
- static_args
+ static_params
+ static_args
in
id_solver.id2node idref static_args_eff lxm
-
+
(** [check_static_arg this pn id sa (symbols, acc)] compile a static arg
into a static_arg_eff
*)
@@ -111,58 +111,58 @@ and (check_static_arg : CompiledData.id_solver ->
fun node_id_solver sp sa ->
let sa_eff =
match sa.it, sp.it with
- | StaticArgIdent idref, StaticParamConst(id, _type_exp) ->
- let ceff = node_id_solver.id2const idref sa.src in
- ConstStaticArgEff (id, ceff)
-
- | StaticArgIdent idref, StaticParamType(id) ->
- let teff = node_id_solver.id2type idref sa.src in
- TypeStaticArgEff (id, teff)
-
- | StaticArgIdent idref, StaticParamNode(id,_,_,_) ->
- let sargs = [] in
- (* We suppose that static arg cannot themselves be
- template calls (eg, f<<g<<3>>>> is forbidden)
- *)
- let neff = node_id_solver.id2node idref sargs sa.src in
- NodeStaticArgEff (id, neff)
-
- | StaticArgConst ce, StaticParamConst(id, _type_exp) -> (
- let ceff = EvalConst.f node_id_solver ce in
- match ceff with
- | [ceff] -> ConstStaticArgEff (id,ceff)
- | _ -> assert false (* should not occur *)
- )
- | StaticArgType te, StaticParamType id ->
- let teff = typ node_id_solver te in
- TypeStaticArgEff (id, teff)
-
- | StaticArgNode(CALL_n ne), StaticParamNode(id,_,_,_) ->
- let neff = node node_id_solver ne in
- NodeStaticArgEff (id, neff)
-
- | StaticArgNode(Predef (op,sargs)), StaticParamNode(id,_,_,_) ->
- let sargs_eff =
- translate_predef_static_args node_id_solver sargs sa.src
- in
- let opeff = PredefEvalType.make_node_exp_eff None op sa.src sargs_eff in
- NodeStaticArgEff (id, opeff)
-
- | StaticArgNode(
- (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)), _ -> assert false
-
- | StaticArgType _, StaticParamNode(id,_,_,_)
- | StaticArgType _, StaticParamConst(id,_)
-
- | StaticArgNode _, StaticParamType(id)
- | StaticArgNode _, StaticParamConst(id,_)
-
- | StaticArgConst _, StaticParamNode(id,_,_,_)
- | StaticArgConst _, StaticParamType(id)
- ->
- assert false (* can it occur actually? Let's wait it occurs...*)
+ | StaticArgIdent idref, StaticParamConst(id, _type_exp) ->
+ let ceff = node_id_solver.id2const idref sa.src in
+ ConstStaticArgEff (id, ceff)
+
+ | StaticArgIdent idref, StaticParamType(id) ->
+ let teff = node_id_solver.id2type idref sa.src in
+ TypeStaticArgEff (id, teff)
+
+ | StaticArgIdent idref, StaticParamNode(id,_,_,_) ->
+ let sargs = [] in
+ (* We suppose that static arg cannot themselves be
+ template calls (eg, f<<g<<3>>>> is forbidden)
+ *)
+ let neff = node_id_solver.id2node idref sargs sa.src in
+ NodeStaticArgEff (id, neff)
+
+ | StaticArgConst ce, StaticParamConst(id, _type_exp) -> (
+ let ceff = EvalConst.f node_id_solver ce in
+ match ceff with
+ | [ceff] -> ConstStaticArgEff (id,ceff)
+ | _ -> assert false (* should not occur *)
+ )
+ | StaticArgType te, StaticParamType id ->
+ let teff = typ node_id_solver te in
+ TypeStaticArgEff (id, teff)
+
+ | StaticArgNode(CALL_n ne), StaticParamNode(id,_,_,_) ->
+ let neff = node node_id_solver ne in
+ NodeStaticArgEff (id, neff)
+
+ | StaticArgNode(Predef (op,sargs)), StaticParamNode(id,_,_,_) ->
+ let sargs_eff =
+ translate_predef_static_args node_id_solver sargs sa.src
+ in
+ let opeff = PredefEvalType.make_node_exp_eff None op sa.src sargs_eff in
+ NodeStaticArgEff (id, opeff)
+
+ | StaticArgNode(
+ (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)), _ -> assert false
+
+ | StaticArgType _, StaticParamNode(id,_,_,_)
+ | StaticArgType _, StaticParamConst(id,_)
+
+ | StaticArgNode _, StaticParamType(id)
+ | StaticArgNode _, StaticParamConst(id,_)
+
+ | StaticArgConst _, StaticParamNode(id,_,_,_)
+ | StaticArgConst _, StaticParamType(id)
+ ->
+ assert false (* can it occur actually? Let's wait it occurs...*)
in
sa_eff
@@ -185,62 +185,62 @@ and (translate_left_part : id_solver -> left_part -> left_eff) =
fun id_solver lp_top ->
match lp_top with
| LeftVar id ->
- let vi_eff =
+ let vi_eff =
id_solver.id2var (Ident.idref_of_string (Ident.to_string id.it)) id.src
in
- LeftVarEff (vi_eff, id.src)
-
+ LeftVarEff (vi_eff, id.src)
+
| LeftField (lp, id) -> (
- let lp_eff = translate_left_part id_solver lp in
- let teff = CompiledData.type_eff_of_left_eff lp_eff in
- (* check that [lp_eff] is a struct that have a field named [id] *)
- match teff with
- | Struct_type_eff(_, fl) -> (
- try let (teff_field,_) = List.assoc id.it fl in
- LeftFieldEff(lp_eff, id.it, teff_field)
- with Not_found ->
- raise (Compile_error(id.src, "bad field name in structure"))
- )
- | _ -> raise (Compile_error(id.src, "a structure was expected"))
- )
+ let lp_eff = translate_left_part id_solver lp in
+ let teff = CompiledData.type_eff_of_left_eff lp_eff in
+ (* check that [lp_eff] is a struct that have a field named [id] *)
+ match teff with
+ | Struct_type_eff(_, fl) -> (
+ try let (teff_field,_) = List.assoc id.it fl in
+ LeftFieldEff(lp_eff, id.it, teff_field)
+ with Not_found ->
+ raise (Compile_error(id.src, "bad field name in structure"))
+ )
+ | _ -> raise (Compile_error(id.src, "a structure was expected"))
+ )
| LeftArray (lp, vef) -> (
- let lp_eff = translate_left_part id_solver lp in
- let teff = CompiledData.type_eff_of_left_eff lp_eff in
- let lxm = vef.src in
- match teff with
- | Array_type_eff(teff_elt, size) ->
- let index = EvalConst.eval_array_index id_solver vef.it size lxm in
- LeftArrayEff(lp_eff, index, teff_elt)
-
- | _ -> raise (Compile_error(vef.src, "an array was expected"))
- )
+ let lp_eff = translate_left_part id_solver lp in
+ let teff = CompiledData.type_eff_of_left_eff lp_eff in
+ let lxm = vef.src in
+ match teff with
+ | Array_type_eff(teff_elt, size) ->
+ let index = EvalConst.eval_array_index id_solver vef.it size lxm in
+ LeftArrayEff(lp_eff, index, teff_elt)
+
+ | _ -> raise (Compile_error(vef.src, "an array was expected"))
+ )
| LeftSlice (lp, sif) -> (
- let lp_eff = translate_left_part id_solver lp in
- let teff = CompiledData.type_eff_of_left_eff lp_eff in
- match teff with
- | Array_type_eff(teff_elt, size) ->
- let sieff = translate_slice_info id_solver sif.it size sif.src in
- let size_slice = sieff.se_width in
- let teff_slice = Array_type_eff(teff_elt, size_slice) in
- LeftSliceEff(lp_eff, sieff, teff_slice)
- | _ -> raise (Compile_error(sif.src, "an array was expected"))
- )
+ let lp_eff = translate_left_part id_solver lp in
+ let teff = CompiledData.type_eff_of_left_eff lp_eff in
+ match teff with
+ | Array_type_eff(teff_elt, size) ->
+ let sieff = translate_slice_info id_solver sif.it size sif.src in
+ let size_slice = sieff.se_width in
+ let teff_slice = Array_type_eff(teff_elt, size_slice) in
+ LeftSliceEff(lp_eff, sieff, teff_slice)
+ | _ -> raise (Compile_error(sif.src, "an array was expected"))
+ )
and (translate_val_exp : id_solver -> val_exp -> val_exp_eff) =
fun id_solver ve ->
match ve with
| CallByName(by_name_op, field_list) ->
- (CallByNameEff(
- flagit (translate_by_name_op id_solver by_name_op) by_name_op.src,
- List.map (translate_field id_solver) field_list))
+ (CallByNameEff(
+ flagit (translate_by_name_op id_solver by_name_op) by_name_op.src,
+ List.map (translate_field id_solver) field_list))
| CallByPos(by_pos_op, Oper vel) ->
- let vel_eff = List.map (translate_val_exp id_solver) vel in
- let by_pos_op_eff = translate_by_pos_op id_solver by_pos_op vel in
- CallByPosEff(flagit by_pos_op_eff by_pos_op.src, OperEff vel_eff)
-
-
+ let vel_eff = List.map (translate_val_exp id_solver) vel in
+ let by_pos_op_eff = translate_by_pos_op id_solver by_pos_op vel in
+ CallByPosEff(flagit by_pos_op_eff by_pos_op.src, OperEff vel_eff)
+
+
and translate_by_name_op id_solver op =
match op.it with
| STRUCT_anonymous_n -> STRUCT_anonymous_eff
@@ -269,14 +269,14 @@ and get_const id_solver const_or_const_ident lxm =
and get_node id_solver node_or_node_ident lxm =
match node_or_node_ident with
| StaticArgIdent(id) ->
- let sargs = [] in (* I should do something more clever here to support
- imbricated use of iterators (e.g., "map<<map<<..." *)
- id_solver.id2node id sargs lxm
+ let sargs = [] in (* I should do something more clever here to support
+ imbricated use of iterators (e.g., "map<<map<<..." *)
+ id_solver.id2node id sargs lxm
| StaticArgNode(CALL_n ne) -> node id_solver ne
| StaticArgNode(Predef (op,sargs)) ->
- let sargs_eff = translate_predef_static_args id_solver sargs lxm in
- PredefEvalType.make_node_exp_eff None op lxm sargs_eff
+ let sargs_eff = translate_predef_static_args id_solver sargs lxm in
+ PredefEvalType.make_node_exp_eff None op lxm sargs_eff
| StaticArgNode(_) -> assert false
| StaticArgType _
@@ -290,25 +290,25 @@ and (translate_predef_static_args: id_solver -> static_arg srcflagged list ->
match sargs with
| [] -> []
| [{src=lxm_c1;it=c1}; {src=lxm_c2;it=c2}; {src=lxm_c3;it=c3}] ->
- [
- ConstStaticArgEff(Ident.of_string "min", get_const id_solver c1 lxm_c1);
- ConstStaticArgEff(Ident.of_string "max", get_const id_solver c2 lxm_c2);
- ConstStaticArgEff(Ident.of_string "size",get_const id_solver c3 lxm_c3)
- ]
+ [
+ ConstStaticArgEff(Ident.of_string "min", get_const id_solver c1 lxm_c1);
+ ConstStaticArgEff(Ident.of_string "max", get_const id_solver c2 lxm_c2);
+ ConstStaticArgEff(Ident.of_string "size",get_const id_solver c3 lxm_c3)
+ ]
| [{src=lxm_n;it=node}; {src=lxm_c;it=const}] ->
- let node_eff = get_node id_solver node lxm_n in
- [NodeStaticArgEff(Ident.of_string "node", node_eff);
- ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
+ let node_eff = get_node id_solver node lxm_n in
+ [NodeStaticArgEff(Ident.of_string "node", node_eff);
+ ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
| _ ->
- raise (Compile_error(lxm, "bad arguments number for array iterator"))
+ raise (Compile_error(lxm, "bad arguments number for array iterator"))
and (translate_iteror: id_solver -> by_pos_op -> Lxm.t -> by_pos_op_eff) =
fun id_solver op lxm ->
match op with
| Predef(iter_op, sargs) ->
- Predef_eff(iter_op, translate_predef_static_args id_solver sargs lxm)
+ Predef_eff(iter_op, translate_predef_static_args id_solver sargs lxm)
| _ -> assert false
@@ -316,7 +316,7 @@ and (translate_by_pos_op : id_solver -> by_pos_op srcflagged -> val_exp list ->
by_pos_op_eff) =
fun id_solver {it=by_pos_op;src=lxm} args ->
match by_pos_op with
- (* put that in another module ? yes, see above.*)
+ (* put that in another module ? yes, see above.*)
| Predef(Map, _)
| Predef(Fill, _)
| Predef(Red, _)
@@ -325,9 +325,9 @@ and (translate_by_pos_op : id_solver -> by_pos_op srcflagged -> val_exp list ->
(* other predef operators *)
| Predef(op, args) -> assert (args=[]); Predef_eff (op,[])
-
+
| CALL_n node_exp_f ->
- CALL_eff (flagit (node id_solver node_exp_f) node_exp_f.src)
+ CALL_eff (flagit (node id_solver node_exp_f) node_exp_f.src)
| IDENT_n idref -> (
try
@@ -357,79 +357,79 @@ and (translate_by_pos_op : id_solver -> by_pos_op srcflagged -> val_exp list ->
| TUPLE_n -> TUPLE_eff
| ARRAY_n -> ARRAY_eff
| WITH_n(c,e1,e2) ->
- let c_eff = EvalConst.f id_solver c in
- if c_eff = [ Bool_const_eff true ] then
- WITH_eff (translate_val_exp id_solver e1)
- else
- WITH_eff (translate_val_exp id_solver e2)
+ let c_eff = EvalConst.f id_solver c in
+ if c_eff = [ Bool_const_eff true ] then
+ WITH_eff (translate_val_exp id_solver e1)
+ else
+ WITH_eff (translate_val_exp id_solver e2)
| STRUCT_ACCESS_n id -> STRUCT_ACCESS_eff id
| WHEN_n ->
- (match List.map (translate_val_exp id_solver) args with
- | [_;CallByPosEff({it=IDENT_eff id; src=lxm}, _)] ->
- let clk = try (id_solver.id2var id lxm) with _ -> assert false in
- WHEN_eff clk
-
- | [_;CallByPosEff
- ({it=Predef_eff(NOT_n,[])},
- OperEff [CallByPosEff({src = lxm; it = IDENT_eff id}, _)])] ->
- let clk = try (id_solver.id2var id lxm) with _ -> assert false in
- WHENOT_eff clk
-
- | _ ->
- let msg = "syntax error: clock expr expected" in
- raise (Compile_error(lxm, msg))
- )
+ (match List.map (translate_val_exp id_solver) args with
+ | [_;CallByPosEff({it=IDENT_eff id; src=lxm}, _)] ->
+ let clk = try (id_solver.id2var id lxm) with _ -> assert false in
+ WHEN_eff clk
+
+ | [_;CallByPosEff
+ ({it=Predef_eff(NOT_n,[])},
+ OperEff [CallByPosEff({src = lxm; it = IDENT_eff id}, _)])] ->
+ let clk = try (id_solver.id2var id lxm) with _ -> assert false in
+ WHENOT_eff clk
+
+ | _ ->
+ let msg = "syntax error: clock expr expected" in
+ raise (Compile_error(lxm, msg))
+ )
| ARRAY_ACCES_n ve_index ->
- let teff =
- assert (List.length args = 1);
- EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
- in
- let size, teff_elt =
- match teff with
- | [Array_type_eff(teff_elt, size)] -> size, teff_elt
- | _ ->
- raise (Compile_error(
- lxm, "\n*** Type error: '" ^
- (LicDump.string_of_type_eff_list teff) ^
- "' was expected to be an array"))
- in
- ARRAY_ACCES_eff(
- EvalConst.eval_array_index id_solver ve_index size lxm,
- teff_elt
- )
+ let teff =
+ assert (List.length args = 1);
+ EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
+ in
+ let size, teff_elt =
+ match teff with
+ | [Array_type_eff(teff_elt, size)] -> size, teff_elt
+ | _ ->
+ raise (Compile_error(
+ lxm, "\n*** Type error: '" ^
+ (LicDump.string_of_type_eff_list teff) ^
+ "' was expected to be an array"))
+ in
+ ARRAY_ACCES_eff(
+ EvalConst.eval_array_index id_solver ve_index size lxm,
+ teff_elt
+ )
| ARRAY_SLICE_n si ->
- let teff =
- assert (List.length args = 1);
- EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
- in
- let size, teff_elt =
- match teff with
- | [Array_type_eff(teff_elt, size)] -> size, teff_elt
- | _ ->
- raise (Compile_error(
- lxm, "\n*** Type error: '" ^
- (LicDump.string_of_type_eff_list teff) ^
- "' was expected to be an array"))
- in
- ARRAY_SLICE_eff(EvalConst.eval_array_slice id_solver si size lxm,
- teff_elt)
+ let teff =
+ assert (List.length args = 1);
+ EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
+ in
+ let size, teff_elt =
+ match teff with
+ | [Array_type_eff(teff_elt, size)] -> size, teff_elt
+ | _ ->
+ raise (Compile_error(
+ lxm, "\n*** Type error: '" ^
+ (LicDump.string_of_type_eff_list teff) ^
+ "' was expected to be an array"))
+ in
+ ARRAY_SLICE_eff(EvalConst.eval_array_slice id_solver si size lxm,
+ teff_elt)
| HAT_n -> (
- match args with
- | [exp; ve_size] ->
- let size_const_eff = EvalConst.f id_solver ve_size
- and exp_eff = translate_val_exp id_solver exp in
- (match size_const_eff with
- | [Int_const_eff size] -> HAT_eff(size, exp_eff)
- | _ -> assert false)
- | _ -> assert false
- )
+ match args with
+ | [exp; ve_size] ->
+ let size_const_eff = EvalConst.f id_solver ve_size
+ and exp_eff = translate_val_exp id_solver exp in
+ (match size_const_eff with
+ | [Int_const_eff size] -> HAT_eff(size, exp_eff)
+ | _ -> assert false)
+ | _ -> assert false
+ )
| MERGE_n(id, idl) -> MERGE_eff(id, idl)
-
+
and (translate_slice_info : id_solver -> slice_info -> int -> Lxm.t ->
slice_info_eff) =
fun id_solver si size lxm ->
@@ -445,15 +445,15 @@ let (assertion : CompiledData.id_solver -> SyntaxTreeCore.val_exp Lxm.srcflagged
(* Check that the assert is a bool. *)
let evaled_exp = EvalType.f id_solver val_exp_eff in
List.iter
- (fun ve ->
- if ve <> Bool_type_eff then
- let msg = "type mismatch: \n\tthe content of the assertion is of type "
- ^ (LicDump.string_of_type_eff ve)
- ^ " whereas it shoud be a Boolean\n"
- in
- raise (Compile_error(vef.src, msg))
- )
- evaled_exp;
+ (fun ve ->
+ if ve <> Bool_type_eff then
+ let msg = "type mismatch: \n\tthe content of the assertion is of type "
+ ^ (LicDump.string_of_type_eff ve)
+ ^ " whereas it shoud be a Boolean\n"
+ in
+ raise (Compile_error(vef.src, msg))
+ )
+ evaled_exp;
(* type is ok *)
(* Clock check the assertion*)
diff --git a/src/ident.ml b/src/ident.ml
index b4552018..5b9873a5 100644
--- a/src/ident.ml
+++ b/src/ident.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 23/07/2008 (at 10:05) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:28) by Erwan Jahier> *)
(* J'ai appele ca symbol (mais ca remplace le ident) :
c'est juste une couche qui garantit l'unicite en memoire
@@ -115,7 +115,7 @@ let idref_of_string s = (
let (long_of_string : string -> long) =
fun s ->
match (Str.split (Str.regexp "::") s) with
- [i] -> !dft_pack_name, i
+ [i] -> !dft_pack_name, i
| [p;i]-> p, i
| _ -> raise (Failure ("idref_of_string: \""^s^"\" not a proper ident"))
@@ -135,7 +135,7 @@ let (to_idref : t -> idref) =
let (long_of_idref : idref -> long) =
fun idr ->
match pack_of_idref idr with
- Some p -> (p, name_of_idref idr)
+ Some p -> (p, name_of_idref idr)
| None -> (!dft_pack_name, name_of_idref idr)
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 132c9bef..2fbecf86 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 27/08/2008 (at 11:43) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:28) by Erwan Jahier> *)
open Lxm
@@ -155,9 +155,9 @@ let x_check
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 *)
+ 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 (Checked res);
@@ -173,15 +173,15 @@ let x_check_interface
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
+ | 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 (Checked res);
res
@@ -192,7 +192,7 @@ let lookup_x_eff x_label id_of_x_key x_tab x_key lxm =
match Hashtbl.find x_tab x_key with
| Checked res -> res
| Checking ->
- raise (Recursion_error (id_of_x_key x_key, [x_label^(Lxm.details lxm)]))
+ raise (Recursion_error (id_of_x_key x_key, [x_label^(Lxm.details lxm)]))
| Incorrect -> raise (BadCheckRef_error)
let (lookup_type_eff: (item_key, CompiledData.type_eff check_flag) Hashtbl.t ->
@@ -223,21 +223,21 @@ let solve_x_idref
match Ident.pack_of_idref idr with
| Some p -> 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
+ (* 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
+ | 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")))
+ with Not_found ->
+ (raise (Compile_error(lxm,"unbounded " ^ x_label ^ " ident")))
(* And now we can start the big mutually recursive definition... *)
@@ -299,14 +299,14 @@ and (type_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
type_check_do this type_name lxm prov_symbols true pack_name type_def
in
if CompiledData.type_eff_are_compatible prov_type_eff body_type_eff then
- prov_type_eff
+ prov_type_eff
else
- raise(Compile_error (
- type_def.src,
- ("provided type \n\t" ^
- (LicDump.string_of_type_eff prov_type_eff) ^
- "\n is not compatible with its implementation \n\t" ^
- (LicDump.string_of_type_eff body_type_eff))))
+ raise(Compile_error (
+ type_def.src,
+ ("provided type \n\t" ^
+ (LicDump.string_of_type_eff prov_type_eff) ^
+ "\n is not compatible with its implementation \n\t" ^
+ (LicDump.string_of_type_eff body_type_eff))))
and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
@@ -316,35 +316,35 @@ and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
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 with
- | Extern_const_eff (id, teff_prov, v_opt) ->
- let teff_body = type_of_const_eff body_const_eff in
- if (id <> cn) then
- assert false
- else if v_opt <> None && v_opt <> Some(body_const_eff) then
- raise(Compile_error (const_def.src, " constant values mismatch"))
- else if CompiledData.type_eff_are_compatible teff_prov teff_body then
- prov_const_eff
- else
- raise(Compile_error (
- const_def.src,
- ("provided constant type \n***\t" ^
- (LicDump.string_of_type_eff teff_prov) ^
- " is not compatible with its implementation \n***\t" ^
- (LicDump.string_of_type_eff teff_body) ^ "")
- ))
- | Enum_const_eff (_, _)
- | Bool_const_eff _
- | Int_const_eff _
- | Real_const_eff _
- | Struct_const_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."))
+ | Extern_const_eff (id, teff_prov, v_opt) ->
+ let teff_body = type_of_const_eff body_const_eff in
+ if (id <> cn) then
+ assert false
+ else if v_opt <> None && v_opt <> Some(body_const_eff) then
+ raise(Compile_error (const_def.src, " constant values mismatch"))
+ else if CompiledData.type_eff_are_compatible teff_prov teff_body then
+ prov_const_eff
+ else
+ raise(Compile_error (
+ const_def.src,
+ ("provided constant type \n***\t" ^
+ (LicDump.string_of_type_eff teff_prov) ^
+ " is not compatible with its implementation \n***\t" ^
+ (LicDump.string_of_type_eff teff_body) ^ "")
+ ))
+ | Enum_const_eff (_, _)
+ | Bool_const_eff _
+ | Int_const_eff _
+ | Real_const_eff _
+ | Struct_const_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."))
and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
@@ -354,63 +354,63 @@ and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
try (
(* Solveur d'idref pour 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 pack_name;
- id2type = solve_type_idref this symbols provide_flag pack_name;
- id2node = solve_node_idref this symbols provide_flag pack_name;
- symbols = symbols;
+ id2var = (fun idref lxm -> assert false (* 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 -> External_type_eff (Ident.make_long pack_name s)
- | 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 = type_of_const_eff 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_eff teff)
- (LicDump.string_of_type_eff 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)
- )
+ match type_def.it with
+ | ArrayType _ -> finish_me " array handling "; assert false
+ | ExternalType s -> External_type_eff (Ident.make_long pack_name s)
+ | 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 = type_of_const_eff 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_eff teff)
+ (LicDump.string_of_type_eff 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
- if not provide_flag then
- output_string !Global.oc (LicDump.type_decl type_name type_eff);
- type_eff
+ if not provide_flag then
+ 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))
-
-
+ (* 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 ->
CompiledData.const_eff) =
@@ -421,58 +421,58 @@ and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
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;
+ 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) ->
- Extern_const_eff ((Ident.make_long currpack id),
- GetEff.typ id_solver texp,
- match val_opt with
- | None -> None
- | Some c -> (
- match EvalConst.f id_solver c with
- | [ceff] -> Some ceff
- | _ -> assert false
- )
- )
- | 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 = type_of_const_eff 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_eff tdecl)
- (LicDump.string_of_type_eff teff)
- )))
- )
- | [] -> assert false (* should not occur *)
- | _::_ -> raise (Compile_error(const_def.src,
- "bad constant value: tuple not allowed"))
- )
+ match const_def.it with
+ | ExternalConst (id, texp, val_opt) ->
+ Extern_const_eff ((Ident.make_long currpack id),
+ GetEff.typ id_solver texp,
+ match val_opt with
+ | None -> None
+ | Some c -> (
+ match EvalConst.f id_solver c with
+ | [ceff] -> Some ceff
+ | _ -> assert false
+ )
+ )
+ | 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 = type_of_const_eff 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_eff tdecl)
+ (LicDump.string_of_type_eff teff)
+ )))
+ )
+ | [] -> assert false (* should not occur *)
+ | _::_ -> raise (Compile_error(const_def.src,
+ "bad constant value: tuple not allowed"))
+ )
in
- if not provide_flag then
- output_string !Global.oc (LicDump.const_decl cn const_eff);
- const_eff
+ if not provide_flag then
+ 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))
+ (* on complete la stack *)
+ raise (Recursion_error (root, ("const ref "^(Lxm.details lxm))::stack))
)
@@ -484,11 +484,11 @@ and (node_check_interface_do: t -> CompiledData.node_key -> Lxm.t ->
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.
+ 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: ")
+ " is not compatible with its implementation: ")
in
let str_of_var = LicDump.type_string_of_var_info_eff in
let type_is_not_comp v1 v2 = not (CompiledData.var_eff_are_compatible v1 v2) in
@@ -497,8 +497,8 @@ and (node_check_interface_do: t -> CompiledData.node_key -> Lxm.t ->
then
raise(Compile_error (node_def.src, msg_prefix ^ " ??? "))
else if
- (List.exists2 type_is_not_comp
- prov_node_exp_eff.inlist_eff body_node_exp_eff.inlist_eff)
+ (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)) ^
@@ -507,8 +507,8 @@ and (node_check_interface_do: t -> CompiledData.node_key -> Lxm.t ->
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)
+ (List.exists2 type_is_not_comp
+ prov_node_exp_eff.outlist_eff body_node_exp_eff.outlist_eff)
then
let msg = msg_prefix ^ "bad output profile. \n*** " ^
(String.concat "*" (List.map str_of_var prov_node_exp_eff.outlist_eff)) ^
@@ -517,21 +517,21 @@ and (node_check_interface_do: t -> CompiledData.node_key -> Lxm.t ->
in
raise(Compile_error (node_def.src, msg))
else if
- prov_node_exp_eff.has_mem_eff <> body_node_exp_eff.has_mem_eff
+ 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
+ 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
+ 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
- prov_node_exp_eff
+ prov_node_exp_eff
and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
@@ -541,249 +541,249 @@ and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
let local_env = make_local_env nk 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. *)
+ 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 (Compile_error(
- lxm,
- "\n*** '"^(Ident.string_of_idref id)^
- "': Unknown variable.\n*** Current variables are: " ^
- (Hashtbl.fold
- (fun id vi_eff acc ->
- acc ^ (Format.sprintf
- "\n\t%s" (LicDump.string_of_var_info_eff vi_eff))
- )
- local_env.lenv_vars
- ""
- ))));
+ (fun id lxm ->
+ try lookup_var local_env (Ident.of_idref id) lxm
+ with Not_found ->
+ raise (Compile_error(
+ lxm,
+ "\n*** '"^(Ident.string_of_idref id)^
+ "': Unknown variable.\n*** Current variables are: " ^
+ (Hashtbl.fold
+ (fun id vi_eff acc ->
+ acc ^ (Format.sprintf
+ "\n\t%s" (LicDump.string_of_var_info_eff vi_eff))
+ )
+ local_env.lenv_vars
+ ""
+ ))));
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);
+ (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 ->
- solve_type_idref this symbols provide_flag pack_name id lxm);
+ (fun id lxm ->
+ try lookup_type local_env id lxm
+ with Not_found ->
+ solve_type_idref this symbols provide_flag pack_name id lxm);
id2node =
- (fun id sargs lxm ->
- try lookup_node local_env id sargs lxm
- with Not_found ->
- solve_node_idref this symbols provide_flag pack_name id sargs lxm);
+ (fun id sargs lxm ->
+ try lookup_node local_env id sargs lxm
+ with Not_found ->
+ solve_node_idref this symbols provide_flag pack_name id sargs lxm);
symbols = symbols;
}
in
let make_node_eff node_def_eff =
(* building not aliased nodes *)
match node_def.it.vars with
- | None -> assert false (* a node with a body should have a profile *)
- | Some vars ->
- let type_args id =
- let vi = Hashtbl.find vars.vartable id in
- let t_eff = GetEff.typ node_id_solver vi.it.var_type 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 (Hashtbl.find vars.vartable 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 (Hashtbl.find vars.vartable 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;
+ | None -> assert false (* a node with a body should have a profile *)
+ | Some vars ->
+ let type_args id =
+ let vi = Hashtbl.find vars.vartable id in
+ let t_eff = GetEff.typ node_id_solver vi.it.var_type 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 (Hashtbl.find vars.vartable 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 (Hashtbl.find vars.vartable 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;
lxm = lxm;
- }
+ }
in
let is_a_predef_node n =
Ident.pack_name_to_string (Ident.pack_of_long (fst n.node_key_eff)) = "Lustre"
in
let (make_alias_node : CompiledData.node_exp_eff -> CompiledData.node_exp_eff) =
fun aliased_node ->
- (* builds a node that calls the aliased node. It looks like:
- node alias_node( ins ) returns ( outs );
- let
- outs = aliased_node(ins);
- tel
- *)
- let (outs:left_eff list) =
- List.map (fun vi -> LeftVarEff (vi, lxm)) aliased_node.outlist_eff
- and (aliased_node_call : val_exp_eff) =
- CallByPosEff(
- (Lxm.flagit (CALL_eff(Lxm.flagit aliased_node lxm)) lxm,
- OperEff
- (List.map
- (fun vi -> (* build operands*)
- CallByPosEff(
- Lxm.flagit (IDENT_eff
- (Ident.to_idref vi.var_name_eff)) lxm, OperEff [])
- )
- aliased_node.inlist_eff)))
- in
- {
- aliased_node with
- node_key_eff = nk;
- loclist_eff = None;
- def_eff = BodyEff(
- { asserts_eff = [];
- eqs_eff = [Lxm.flagit (outs, aliased_node_call) lxm]
- });
- }
+ (* builds a node that calls the aliased node. It looks like:
+ node alias_node( ins ) returns ( outs );
+ let
+ outs = aliased_node(ins);
+ tel
+ *)
+ let (outs:left_eff list) =
+ List.map (fun vi -> LeftVarEff (vi, lxm)) aliased_node.outlist_eff
+ and (aliased_node_call : val_exp_eff) =
+ CallByPosEff(
+ (Lxm.flagit (CALL_eff(Lxm.flagit aliased_node lxm)) lxm,
+ OperEff
+ (List.map
+ (fun vi -> (* build operands*)
+ CallByPosEff(
+ Lxm.flagit (IDENT_eff
+ (Ident.to_idref vi.var_name_eff)) lxm, OperEff [])
+ )
+ aliased_node.inlist_eff)))
+ in
+ {
+ aliased_node with
+ node_key_eff = nk;
+ loclist_eff = None;
+ def_eff = BodyEff(
+ { asserts_eff = [];
+ eqs_eff = [Lxm.flagit (outs, aliased_node_call) lxm]
+ });
+ }
in
(* let's go *)
let res =
match node_def.it.def with
- | Abstract -> make_node_eff (fun () -> AbstractEff)
- | Extern -> make_node_eff (fun () -> ExternEff)
- | Body nb ->
- make_node_eff (
- (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((Predef.NOR_n|Predef.DIESE_n), sargs) ->
- raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
-(* | Predef( *)
-(* (Predef.NEQ_n | Predef.EQ_n | Predef.LT_n | Predef.LTE_n *)
-(* | Predef.GT_n | Predef.GTE_n | Predef.IF_n), _sargs *)
-(* ) -> *)
-(* raise (Compile_error ( *)
-(* lxm, "can not alias polymorphic operators, sorry")) *)
-(* | Predef( *)
-(* ( Predef.UMINUS_n | Predef.MINUS_n | Predef.PLUS_n *)
-(* | Predef.TIMES_n | Predef.SLASH_n), _sargs *)
-(* ) -> *)
-(* raise (Compile_error ( *)
-(* lxm, "can not alias overloaded operators, sorry")) *)
-
- | Predef(predef_op, sargs) ->
- let sargs_eff =
- GetEff.translate_predef_static_args node_id_solver sargs lxm
- in
- PredefEvalType.make_node_exp_eff
+ | Abstract -> make_node_eff (fun () -> AbstractEff)
+ | Extern -> make_node_eff (fun () -> ExternEff)
+ | Body nb ->
+ make_node_eff (
+ (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((Predef.NOR_n|Predef.DIESE_n), sargs) ->
+ raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
+(* | Predef( *)
+(* (Predef.NEQ_n | Predef.EQ_n | Predef.LT_n | Predef.LTE_n *)
+(* | Predef.GT_n | Predef.GTE_n | Predef.IF_n), _sargs *)
+(* ) -> *)
+(* raise (Compile_error ( *)
+(* lxm, "can not alias polymorphic operators, sorry")) *)
+(* | Predef( *)
+(* ( Predef.UMINUS_n | Predef.MINUS_n | Predef.PLUS_n *)
+(* | Predef.TIMES_n | Predef.SLASH_n), _sargs *)
+(* ) -> *)
+(* raise (Compile_error ( *)
+(* lxm, "can not alias overloaded operators, sorry")) *)
+
+ | Predef(predef_op, sargs) ->
+ let sargs_eff =
+ GetEff.translate_predef_static_args node_id_solver sargs lxm
+ in
+ PredefEvalType.make_node_exp_eff
(Some node_def.it.has_mem) predef_op lxm sargs_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 alias_node = make_alias_node aliased_node in
- (* 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 -> Hashtbl.find vars.vartable id) vars.inlist,
- List.map (fun id -> Hashtbl.find vars.vartable id) vars.outlist
- in
- let aux vi = GetEff.typ node_id_solver vi.it.var_type
- in
- let (il,ol) = CompiledData.profile_of_node_exp_eff alias_node in
- let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in
- match UnifyType.f il_exp il with
- | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
- | _ ->
- match UnifyType.f ol_exp ol with
- | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
- | _ ->
- alias_node
- )
+
+ | 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 alias_node = make_alias_node aliased_node in
+ (* 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 -> Hashtbl.find vars.vartable id) vars.inlist,
+ List.map (fun id -> Hashtbl.find vars.vartable id) vars.outlist
+ in
+ let aux vi = GetEff.typ node_id_solver vi.it.var_type
+ in
+ let (il,ol) = CompiledData.profile_of_node_exp_eff alias_node in
+ let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in
+ match UnifyType.f il_exp il with
+ | UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
+ | _ ->
+ match UnifyType.f ol_exp ol with
+ | UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
+ | _ ->
+ alias_node
+ )
in
let res = if !Global.one_op_per_equation then Split.node res else res in
if not provide_flag then
- output_string !Global.oc (LicDump.node_of_node_exp_eff res);
+ output_string !Global.oc (LicDump.node_of_node_exp_eff res);
UniqueOutput.check res node_def.src;
res
@@ -796,11 +796,11 @@ and (solve_node_idref : t -> SymbolTab.t -> bool -> Ident.pack_name -> Ident.idr
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 static_arg_eff list *)
- let long = Ident.make_long p id in
- let node_key = long, sargs in
- node_key
+ (* builds a [node_key] from a [pack_name] and a [node] id,
+ and a static_arg_eff 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
@@ -829,14 +829,14 @@ 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) *)
+ 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) *)
+(* 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 =
@@ -860,9 +860,9 @@ let compile_all_nodes pack_name this id ni_f =
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)
- CompiledData.profile_of_node_exp_eff
- (fun id -> (Ident.make_long pack_name id, [])) id ni_f
+ (LicDump.string_of_node_key_rec)
+ CompiledData.profile_of_node_exp_eff
+ (fun id -> (Ident.make_long pack_name id, [])) id ni_f
let (compile_all :t -> unit) =
@@ -871,8 +871,8 @@ let (compile_all :t -> unit) =
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
+ | 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);
@@ -890,6 +890,6 @@ let (compile_all :t -> unit) =
try
List.iter testpack plist
with
- Recursion_error (root, stack) ->
- recursion_error (Lxm.dummy "") stack
+ Recursion_error (root, stack) ->
+ recursion_error (Lxm.dummy "") stack
diff --git a/src/lexer.mll b/src/lexer.mll
index 83079ee5..89099b09 100644
--- a/src/lexer.mll
+++ b/src/lexer.mll
@@ -11,11 +11,11 @@ open Parser
exception Lexical_error of string * Lxm.t
let handle_lexical_error fn lexbuf = (
- let lxm = Lxm.make (lexbuf ) in
- try
- fn lexbuf
- with Lexical_error(msg, _) ->
- raise(Lexical_error(msg, lxm))
+ let lxm = Lxm.make (lexbuf ) in
+ try
+ fn lexbuf
+ with Lexical_error(msg, _) ->
+ raise(Lexical_error(msg, lxm))
)
(* table des mots-clé *)
@@ -66,95 +66,95 @@ Hashtbl.add keywords "end" (function x -> TK_END x) ;;
Hashtbl.add keywords "include" (function x -> TK_INCLUDE x) ;;
let is_a_keyword ( s: string ) = (
- try
- let res = Hashtbl.find keywords s in (Some res)
- with Not_found -> ( None )
+ try
+ let res = Hashtbl.find keywords s in (Some res)
+ with Not_found -> ( None )
)
let token_code tk = (
- match tk with
- TK_EOF -> ("TK_EOF" , Lxm.dummy "eof")
- | TK_ERROR lxm -> ("TK_ERROR" , lxm)
- | TK_EXTERN lxm -> ("TK_EXTERN" , lxm)
- | TK_AND lxm -> ("TK_AND" , lxm)
- | TK_ARROW lxm -> ("TK_ARROW" , lxm)
- | TK_ASSERT lxm -> ("TK_ASSERT" , lxm)
- | TK_BAR lxm -> ("TK_BAR" , lxm)
- | TK_BOOL lxm -> ("TK_BOOL" , lxm)
- | TK_CDOTS lxm -> ("TK_CDOTS" , lxm)
- | TK_CLOSE_BRACKET lxm -> ("TK_CLOSE_BRACKET" , lxm)
- | TK_CLOSE_BRACE lxm -> ("TK_CLOSE_BRACE" , lxm)
- | TK_CLOSE_PAR lxm -> ("TK_CLOSE_PAR" , lxm)
- | TK_CLOSE_STATIC_PAR lxm -> ("TK_CLOSE_STATIC_PAR" , lxm)
- | TK_COLON lxm -> ("TK_COLON" , lxm)
- | TK_COMA lxm -> ("TK_COMA" , lxm)
- | TK_CONST lxm -> ("TK_CONST" , lxm)
- | TK_CURRENT lxm -> ("TK_CURRENT" , lxm)
- | TK_DIV lxm -> ("TK_DIV" , lxm)
- | TK_DIESE lxm -> ("TK_DIESE" , lxm)
- | TK_DOT lxm -> ("TK_DOT" , lxm)
- | TK_ELSE lxm -> ("TK_ELSE" , lxm)
- | TK_EQ lxm -> ("TK_EQ" , lxm)
- | TK_ENUM lxm -> ("TK_ENUM" , lxm)
- | TK_FALSE lxm -> ("TK_FALSE" , lxm)
- | TK_FIELD lxm -> ("TK_FIELD" , lxm)
- | TK_FUNCTION lxm -> ("TK_FUNCTION" , lxm)
- | TK_GT lxm -> ("TK_GT" , lxm)
- | TK_GTE lxm -> ("TK_GTE" , lxm)
- | TK_HAT lxm -> ("TK_HAT" , lxm)
- | TK_ICONST lxm -> ("TK_ICONT" , lxm)
- | TK_IDENT lxm -> ("TK_IDENT" , lxm)
- | TK_LONGIDENT lxm -> ("TK_LONGIDENT" , lxm)
- | TK_STRING lxm -> ("TK_STRING" , lxm)
- | TK_IF lxm -> ("TK_IF" , lxm)
- | TK_IMPL lxm -> ("TK_IMPL" , lxm)
- | TK_INT lxm -> ("TK_INT" , lxm)
- | TK_LET lxm -> ("TK_LET" , lxm)
- | TK_LT lxm -> ("TK_LT" , lxm)
- | TK_LTE lxm -> ("TK_LTE" , lxm)
- | TK_MINUS lxm -> ("TK_MINUS" , lxm)
- | TK_MOD lxm -> ("TK_MOD" , lxm)
- | TK_NEQ lxm -> ("TK_NEQ" , lxm)
- | TK_NODE lxm -> ("TK_NODE" , lxm)
- | TK_NOR lxm -> ("TK_NOR" , lxm)
- | TK_NOT lxm -> ("TK_NOT" , lxm)
- | TK_OPEN_BRACKET lxm -> ("TK_OPEN_BRACKET" , lxm)
- | TK_OPEN_BRACE lxm -> ("TK_OPEN_BRACE" , lxm)
- | TK_OPEN_PAR lxm -> ("TK_OPEN_PAR" , lxm)
- | TK_OPEN_STATIC_PAR lxm -> ("TK_OPEN_STATIC_PAR" , lxm)
- | TK_OPERATOR lxm -> ("TK_OPERATOR" , lxm)
- | TK_OR lxm -> ("TK_OR" , lxm)
- | TK_PCENT lxm -> ("TK_PCENT" , lxm)
- | TK_PLUS lxm -> ("TK_PLUS" , lxm)
- | TK_POWER lxm -> ("TK_POWER" , lxm)
- | TK_FBY lxm -> ("TK_FBY" , lxm)
- | TK_PRE lxm -> ("TK_PRE" , lxm)
- | TK_RCONST lxm -> ("TK_RCONST" , lxm)
- | TK_REAL lxm -> ("TK_REAL" , lxm)
- | TK_RETURNS lxm -> ("TK_RETURNS" , lxm)
- | TK_SEMICOL lxm -> ("TK_SEMICOL" , lxm)
- | TK_STAR lxm -> ("TK_STAR" , lxm)
- | TK_SLASH lxm -> ("TK_SLASH" , lxm)
- | TK_STEP lxm -> ("TK_STEP" , lxm)
- | TK_STRUCT lxm -> ("TK_STRUCT" , lxm)
- | TK_TEL lxm -> ("TK_TEL" , lxm)
- | TK_THEN lxm -> ("TK_THEN" , lxm)
- | TK_TRUE lxm -> ("TK_TRUE" , lxm)
- | TK_TYPE lxm -> ("TK_TYPE" , lxm)
- | TK_VAR lxm -> ("TK_VAR" , lxm)
- | TK_WHEN lxm -> ("TK_WHEN" , lxm)
- | TK_WITH lxm -> ("TK_WITH" , lxm)
- | TK_XOR lxm -> ("TK_XOR" , lxm)
- | TK_MODEL lxm -> ("TK_MODEL" , lxm)
- | TK_PACKAGE lxm -> ("TK_PACKAGE" , lxm)
- | TK_NEEDS lxm -> ("TK_NEEDS" , lxm)
- | TK_PROVIDES lxm -> ("TK_PROVIDES" , lxm)
- | TK_USES lxm -> ("TK_USES" , lxm)
- | TK_IS lxm -> ("TK_IS" , lxm)
- | TK_BODY lxm -> ("TK_BODY" , lxm)
- | TK_END lxm -> ("TK_END" , lxm)
- | TK_INCLUDE lxm -> ("TK_INCLUDE" , lxm)
- | TK_SLICE_START lxm -> ("TK_SLICE_START" , lxm)
+ match tk with
+ TK_EOF -> ("TK_EOF" , Lxm.dummy "eof")
+ | TK_ERROR lxm -> ("TK_ERROR" , lxm)
+ | TK_EXTERN lxm -> ("TK_EXTERN" , lxm)
+ | TK_AND lxm -> ("TK_AND" , lxm)
+ | TK_ARROW lxm -> ("TK_ARROW" , lxm)
+ | TK_ASSERT lxm -> ("TK_ASSERT" , lxm)
+ | TK_BAR lxm -> ("TK_BAR" , lxm)
+ | TK_BOOL lxm -> ("TK_BOOL" , lxm)
+ | TK_CDOTS lxm -> ("TK_CDOTS" , lxm)
+ | TK_CLOSE_BRACKET lxm -> ("TK_CLOSE_BRACKET" , lxm)
+ | TK_CLOSE_BRACE lxm -> ("TK_CLOSE_BRACE" , lxm)
+ | TK_CLOSE_PAR lxm -> ("TK_CLOSE_PAR" , lxm)
+ | TK_CLOSE_STATIC_PAR lxm -> ("TK_CLOSE_STATIC_PAR" , lxm)
+ | TK_COLON lxm -> ("TK_COLON" , lxm)
+ | TK_COMA lxm -> ("TK_COMA" , lxm)
+ | TK_CONST lxm -> ("TK_CONST" , lxm)
+ | TK_CURRENT lxm -> ("TK_CURRENT" , lxm)
+ | TK_DIV lxm -> ("TK_DIV" , lxm)
+ | TK_DIESE lxm -> ("TK_DIESE" , lxm)
+ | TK_DOT lxm -> ("TK_DOT" , lxm)
+ | TK_ELSE lxm -> ("TK_ELSE" , lxm)
+ | TK_EQ lxm -> ("TK_EQ" , lxm)
+ | TK_ENUM lxm -> ("TK_ENUM" , lxm)
+ | TK_FALSE lxm -> ("TK_FALSE" , lxm)
+ | TK_FIELD lxm -> ("TK_FIELD" , lxm)
+ | TK_FUNCTION lxm -> ("TK_FUNCTION" , lxm)
+ | TK_GT lxm -> ("TK_GT" , lxm)
+ | TK_GTE lxm -> ("TK_GTE" , lxm)
+ | TK_HAT lxm -> ("TK_HAT" , lxm)
+ | TK_ICONST lxm -> ("TK_ICONT" , lxm)
+ | TK_IDENT lxm -> ("TK_IDENT" , lxm)
+ | TK_LONGIDENT lxm -> ("TK_LONGIDENT" , lxm)
+ | TK_STRING lxm -> ("TK_STRING" , lxm)
+ | TK_IF lxm -> ("TK_IF" , lxm)
+ | TK_IMPL lxm -> ("TK_IMPL" , lxm)
+ | TK_INT lxm -> ("TK_INT" , lxm)
+ | TK_LET lxm -> ("TK_LET" , lxm)
+ | TK_LT lxm -> ("TK_LT" , lxm)
+ | TK_LTE lxm -> ("TK_LTE" , lxm)
+ | TK_MINUS lxm -> ("TK_MINUS" , lxm)
+ | TK_MOD lxm -> ("TK_MOD" , lxm)
+ | TK_NEQ lxm -> ("TK_NEQ" , lxm)
+ | TK_NODE lxm -> ("TK_NODE" , lxm)
+ | TK_NOR lxm -> ("TK_NOR" , lxm)
+ | TK_NOT lxm -> ("TK_NOT" , lxm)
+ | TK_OPEN_BRACKET lxm -> ("TK_OPEN_BRACKET" , lxm)
+ | TK_OPEN_BRACE lxm -> ("TK_OPEN_BRACE" , lxm)
+ | TK_OPEN_PAR lxm -> ("TK_OPEN_PAR" , lxm)
+ | TK_OPEN_STATIC_PAR lxm -> ("TK_OPEN_STATIC_PAR" , lxm)
+ | TK_OPERATOR lxm -> ("TK_OPERATOR" , lxm)
+ | TK_OR lxm -> ("TK_OR" , lxm)
+ | TK_PCENT lxm -> ("TK_PCENT" , lxm)
+ | TK_PLUS lxm -> ("TK_PLUS" , lxm)
+ | TK_POWER lxm -> ("TK_POWER" , lxm)
+ | TK_FBY lxm -> ("TK_FBY" , lxm)
+ | TK_PRE lxm -> ("TK_PRE" , lxm)
+ | TK_RCONST lxm -> ("TK_RCONST" , lxm)
+ | TK_REAL lxm -> ("TK_REAL" , lxm)
+ | TK_RETURNS lxm -> ("TK_RETURNS" , lxm)
+ | TK_SEMICOL lxm -> ("TK_SEMICOL" , lxm)
+ | TK_STAR lxm -> ("TK_STAR" , lxm)
+ | TK_SLASH lxm -> ("TK_SLASH" , lxm)
+ | TK_STEP lxm -> ("TK_STEP" , lxm)
+ | TK_STRUCT lxm -> ("TK_STRUCT" , lxm)
+ | TK_TEL lxm -> ("TK_TEL" , lxm)
+ | TK_THEN lxm -> ("TK_THEN" , lxm)
+ | TK_TRUE lxm -> ("TK_TRUE" , lxm)
+ | TK_TYPE lxm -> ("TK_TYPE" , lxm)
+ | TK_VAR lxm -> ("TK_VAR" , lxm)
+ | TK_WHEN lxm -> ("TK_WHEN" , lxm)
+ | TK_WITH lxm -> ("TK_WITH" , lxm)
+ | TK_XOR lxm -> ("TK_XOR" , lxm)
+ | TK_MODEL lxm -> ("TK_MODEL" , lxm)
+ | TK_PACKAGE lxm -> ("TK_PACKAGE" , lxm)
+ | TK_NEEDS lxm -> ("TK_NEEDS" , lxm)
+ | TK_PROVIDES lxm -> ("TK_PROVIDES" , lxm)
+ | TK_USES lxm -> ("TK_USES" , lxm)
+ | TK_IS lxm -> ("TK_IS" , lxm)
+ | TK_BODY lxm -> ("TK_BODY" , lxm)
+ | TK_END lxm -> ("TK_END" , lxm)
+ | TK_INCLUDE lxm -> ("TK_INCLUDE" , lxm)
+ | TK_SLICE_START lxm -> ("TK_SLICE_START" , lxm)
)
}
@@ -167,155 +167,155 @@ let exposant = ( 'e' | 'E' ) ( '+' | '-' )? chiffres
rule lexer = parse
eof
- { TK_EOF }
+ { TK_EOF }
(* saute les blancs *)
(* saute les blancs *)
| [' ' '\013' '\009' '\012'] +
- { lexer lexbuf }
+ { lexer lexbuf }
(* retour à la ligne *)
- | '\n'
- {
- Lxm.new_line ( lexbuf );
- lexer lexbuf
- }
+ | '\n'
+ {
+ Lxm.new_line ( lexbuf );
+ lexer lexbuf
+ }
(* commentaire parenthésé *)
- | "(*"
- {
- handle_lexical_error comment_par lexbuf;
- lexer lexbuf
- }
+ | "(*"
+ {
+ handle_lexical_error comment_par lexbuf;
+ lexer lexbuf
+ }
(* commentaire parenthésé bis *)
- | "/*"
- {
- handle_lexical_error comment_par_bis lexbuf;
- lexer lexbuf
- }
+ | "/*"
+ {
+ handle_lexical_error comment_par_bis lexbuf;
+ lexer lexbuf
+ }
(* commentaire en ligne *)
- | "--"
- {
- handle_lexical_error comment_line lexbuf;
- lexer lexbuf
- }
+ | "--"
+ {
+ handle_lexical_error comment_line lexbuf;
+ lexer lexbuf
+ }
(* mots-clé débutant par un séparateur (prioritaires) *)
- | "->" { TK_ARROW ( Lxm.make lexbuf ) }
- | "=>" { TK_IMPL ( Lxm.make lexbuf ) }
- | "<=" { TK_LTE ( Lxm.make lexbuf ) }
- | "<>" { TK_NEQ ( Lxm.make lexbuf ) }
- | ">=" { TK_GTE ( Lxm.make lexbuf ) }
- | ".%" { TK_FIELD ( Lxm.make lexbuf ) }
- | ".." { TK_CDOTS ( Lxm.make lexbuf ) }
- | "**" { TK_POWER ( Lxm.make lexbuf ) }
- (* parentheses des params statiques ... bof *)
- | "<<" { TK_OPEN_STATIC_PAR ( Lxm.make lexbuf ) }
- | ">>" { TK_CLOSE_STATIC_PAR ( Lxm.make lexbuf ) }
+ | "->" { TK_ARROW ( Lxm.make lexbuf ) }
+ | "=>" { TK_IMPL ( Lxm.make lexbuf ) }
+ | "<=" { TK_LTE ( Lxm.make lexbuf ) }
+ | "<>" { TK_NEQ ( Lxm.make lexbuf ) }
+ | ">=" { TK_GTE ( Lxm.make lexbuf ) }
+ | ".%" { TK_FIELD ( Lxm.make lexbuf ) }
+ | ".." { TK_CDOTS ( Lxm.make lexbuf ) }
+ | "**" { TK_POWER ( Lxm.make lexbuf ) }
+ (* parentheses des params statiques ... bof *)
+ | "<<" { TK_OPEN_STATIC_PAR ( Lxm.make lexbuf ) }
+ | ">>" { TK_CLOSE_STATIC_PAR ( Lxm.make lexbuf ) }
(* séparateurs simples *)
- | "+" { TK_PLUS ( Lxm.make lexbuf ) }
- | "^" { TK_HAT ( Lxm.make lexbuf ) }
- | "#" { TK_DIESE ( Lxm.make lexbuf ) }
- | "-" { TK_MINUS ( Lxm.make lexbuf ) }
- | "/" { TK_SLASH ( Lxm.make lexbuf ) }
- | "%" { TK_PCENT ( Lxm.make lexbuf ) }
- | "*" { TK_STAR ( Lxm.make lexbuf ) }
- | "|" { TK_BAR ( Lxm.make lexbuf ) }
- | "=" { TK_EQ ( Lxm.make lexbuf ) }
+ | "+" { TK_PLUS ( Lxm.make lexbuf ) }
+ | "^" { TK_HAT ( Lxm.make lexbuf ) }
+ | "#" { TK_DIESE ( Lxm.make lexbuf ) }
+ | "-" { TK_MINUS ( Lxm.make lexbuf ) }
+ | "/" { TK_SLASH ( Lxm.make lexbuf ) }
+ | "%" { TK_PCENT ( Lxm.make lexbuf ) }
+ | "*" { TK_STAR ( Lxm.make lexbuf ) }
+ | "|" { TK_BAR ( Lxm.make lexbuf ) }
+ | "=" { TK_EQ ( Lxm.make lexbuf ) }
- | "." { TK_DOT ( Lxm.make lexbuf ) }
-(* | "\"" { TK_QUOTE ( Lxm.make lexbuf ) } *)
- | "," { TK_COMA ( Lxm.make lexbuf ) }
- | ";" { TK_SEMICOL ( Lxm.make lexbuf ) }
- | ":" { TK_COLON ( Lxm.make lexbuf ) }
- | "(" { TK_OPEN_PAR ( Lxm.make lexbuf ) }
- | ")" { TK_CLOSE_PAR ( Lxm.make lexbuf ) }
- | "{" { TK_OPEN_BRACE ( Lxm.make lexbuf ) }
- | "}" { TK_CLOSE_BRACE ( Lxm.make lexbuf ) }
- | "[" { TK_OPEN_BRACKET ( Lxm.make lexbuf ) }
- | "]" { TK_CLOSE_BRACKET ( Lxm.make lexbuf ) }
- | "<" { TK_LT ( Lxm.make lexbuf ) }
- | ">" { TK_GT ( Lxm.make lexbuf ) }
+ | "." { TK_DOT ( Lxm.make lexbuf ) }
+(* | "\"" { TK_QUOTE ( Lxm.make lexbuf ) } *)
+ | "," { TK_COMA ( Lxm.make lexbuf ) }
+ | ";" { TK_SEMICOL ( Lxm.make lexbuf ) }
+ | ":" { TK_COLON ( Lxm.make lexbuf ) }
+ | "(" { TK_OPEN_PAR ( Lxm.make lexbuf ) }
+ | ")" { TK_CLOSE_PAR ( Lxm.make lexbuf ) }
+ | "{" { TK_OPEN_BRACE ( Lxm.make lexbuf ) }
+ | "}" { TK_CLOSE_BRACE ( Lxm.make lexbuf ) }
+ | "[" { TK_OPEN_BRACKET ( Lxm.make lexbuf ) }
+ | "]" { TK_CLOSE_BRACKET ( Lxm.make lexbuf ) }
+ | "<" { TK_LT ( Lxm.make lexbuf ) }
+ | ">" { TK_GT ( Lxm.make lexbuf ) }
(* identificateur pointé *)
- | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
- ':' ':'
- ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
- {
- let lxm = Lxm.make lexbuf in
- TK_LONGIDENT (lxm)
- }
+ | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
+ ':' ':'
+ ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
+ {
+ let lxm = Lxm.make lexbuf in
+ TK_LONGIDENT (lxm)
+ }
(* Une grosse bidouille pour feinter lex à qui on arrive pas à faire
comprendre que "[expr_min..expr_max]" est une tranche de tableau,
et pas 2 reels qui se suivent ("1..3"), ou bien l'acces à une
structure ("0..max").
*)
- | ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9' ':'] * '.' '.'
- {
- let lxm = Lxm.make lexbuf in
- TK_SLICE_START (lxm)
- }
- (* une chaine quelconque *)
- | "\"" ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' '(' ')' '$' '/' 'a'-'z' '.' '-' '_'] * "\""
- {
- let lxm = Lxm.make_string lexbuf in
- TK_STRING (lxm)
- }
+ | ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9' ':'] * '.' '.'
+ {
+ let lxm = Lxm.make lexbuf in
+ TK_SLICE_START (lxm)
+ }
+ (* une chaine quelconque *)
+ | "\"" ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' '(' ')' '$' '/' 'a'-'z' '.' '-' '_'] * "\""
+ {
+ let lxm = Lxm.make_string lexbuf in
+ TK_STRING (lxm)
+ }
(* constantes entières et réelles *)
- | chiffres { TK_ICONST (Lxm.make lexbuf ) }
+ | chiffres { TK_ICONST (Lxm.make lexbuf ) }
- | chiffres (exposant) { TK_RCONST (Lxm.make lexbuf ) }
+ | chiffres (exposant) { TK_RCONST (Lxm.make lexbuf ) }
- | chiffres '.' (chiffres)? (exposant)? { TK_RCONST (Lxm.make lexbuf ) }
+ | chiffres '.' (chiffres)? (exposant)? { TK_RCONST (Lxm.make lexbuf ) }
- | '.' chiffres (exposant)? { TK_RCONST (Lxm.make lexbuf ) }
+ | '.' chiffres (exposant)? { TK_RCONST (Lxm.make lexbuf ) }
(* mot-clé ou identificateur *)
- | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
- {
- let lxm = Lxm.make lexbuf in
- let x = is_a_keyword ( Lxm.str lxm ) in
- match x with
- None -> TK_IDENT ( lxm )
- | Some keyw -> keyw ( lxm )
- }
- | _ { TK_ERROR ( Lxm.make lexbuf ) }
+ | ['_' 'A'-'Z' 'a'-'z'] ['A'-'Z' 'a'-'z' '\'' '_' '0'-'9'] *
+ {
+ let lxm = Lxm.make lexbuf in
+ let x = is_a_keyword ( Lxm.str lxm ) in
+ match x with
+ None -> TK_IDENT ( lxm )
+ | Some keyw -> keyw ( lxm )
+ }
+ | _ { TK_ERROR ( Lxm.make lexbuf ) }
and comment_par = parse
- "*)"
- { }
- | "\n"
- {
- Lxm.new_line ( lexbuf );
- comment_par lexbuf
- }
- | eof
- {
- raise(Lexical_error("unterminated comment",
- Lxm.dummy "unterminated comment"))
- }
- | _
- { comment_par lexbuf }
+ "*)"
+ { }
+ | "\n"
+ {
+ Lxm.new_line ( lexbuf );
+ comment_par lexbuf
+ }
+ | eof
+ {
+ raise(Lexical_error("unterminated comment",
+ Lxm.dummy "unterminated comment"))
+ }
+ | _
+ { comment_par lexbuf }
and comment_par_bis = parse
- "*/"
- { }
- | "\n"
- {
- Lxm.new_line ( lexbuf );
- comment_par_bis lexbuf
- }
- | eof
- {
- raise(Lexical_error("unterminated comment",
- Lxm.dummy "unterminated comment"))
- }
- | _
- { comment_par_bis lexbuf }
+ "*/"
+ { }
+ | "\n"
+ {
+ Lxm.new_line ( lexbuf );
+ comment_par_bis lexbuf
+ }
+ | eof
+ {
+ raise(Lexical_error("unterminated comment",
+ Lxm.dummy "unterminated comment"))
+ }
+ | _
+ { comment_par_bis lexbuf }
and comment_line = parse
- '\n'
- {
- Lxm.new_line ( lexbuf );
- }
- | eof
- { }
- | _
- { comment_line lexbuf }
+ '\n'
+ {
+ Lxm.new_line ( lexbuf );
+ }
+ | eof
+ { }
+ | _
+ { comment_line lexbuf }
diff --git a/src/licDump.ml b/src/licDump.ml
index 22870159..57083413 100644
--- a/src/licDump.ml
+++ b/src/licDump.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 28/08/2008 (at 10:19) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:22) by Erwan Jahier> *)
open CompiledData
open Printf
@@ -76,16 +76,16 @@ let rec string_of_const_eff = (
| Extern_const_eff (s,t,vopt) -> (long s) ^ (string_of_const_eff_opt vopt)
| Enum_const_eff (s,t) -> (long s)
| Struct_const_eff (fl, t) -> (
- let string_of_field =
- function (id, veff) ->
- (Ident.to_string id)^" = "^(string_of_const_eff veff)
- in
- let flst = List.map string_of_field fl in
- (string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
+ let string_of_field =
+ function (id, veff) ->
+ (Ident.to_string id)^" = "^(string_of_const_eff veff)
+ in
+ let flst = List.map string_of_field fl in
+ (string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
)
| Array_const_eff (ctab, t) -> (
- let vl = Array.to_list(Array.map string_of_const_eff ctab) in
- "["^(String.concat ", " vl)^"]"
+ let vl = Array.to_list(Array.map string_of_const_eff ctab) in
+ "["^(String.concat ", " vl)^"]"
)
)
@@ -101,20 +101,20 @@ and string_def_of_type_eff = function
| Enum_type_eff (i, sl) ->
assert (sl <>[]);
let f sep acc s = acc ^ sep ^ (long s) in
- (List.fold_left (f ", ") (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
+ (List.fold_left (f ", ") (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
| Array_type_eff (ty, sz) -> sprintf "%s^%d" (string_of_type_eff ty) sz
| Struct_type_eff (name, fl) ->
assert (fl <>[]);
let f sep acc (id, (type_eff, const_eff_opt)) =
- acc ^ sep ^ (Ident.to_string id) ^ " : " ^
- (string_of_type_eff type_eff) ^
- match const_eff_opt with
- None -> ""
- | Some ce -> " = " ^ (string_of_const_eff ce)
+ acc ^ sep ^ (Ident.to_string id) ^ " : " ^
+ (string_of_type_eff type_eff) ^
+ match const_eff_opt with
+ None -> ""
+ | Some ce -> " = " ^ (string_of_const_eff ce)
in
"struct " ^
- (List.fold_left (f "; ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
-
+ (List.fold_left (f "; ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
+
| Any -> "a"
| Overload -> "o"
@@ -241,16 +241,16 @@ and string_of_node_key_rec (nkey: node_key) =
match nkey with
| (ik, []) -> long ik
| (ik, salst) ->
- let astrings = List.map static_arg2string_rec salst in
- sprintf "%s_%s" (long ik) (String.concat "_" astrings)
+ let astrings = List.map static_arg2string_rec salst in
+ sprintf "%s_%s" (long ik) (String.concat "_" astrings)
(* for printing iterators *)
and string_of_node_key_iter lxm (nkey: node_key) =
match nkey with
| (ik, []) -> long ik
| (ik, salst) ->
- let astrings = List.map (static_arg2string (Some lxm)) salst in
- sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)
+ let astrings = List.map (static_arg2string (Some lxm)) salst in
+ sprintf "%s<<%s>>" (long ik) (String.concat ", " astrings)
(* for printing recursive node *)
and static_arg2string_rec (sa : static_arg_eff) =
@@ -258,7 +258,7 @@ and static_arg2string_rec (sa : static_arg_eff) =
| ConstStaticArgEff (id, ceff) -> sprintf "%s" (string_of_const_eff ceff)
| TypeStaticArgEff (id, teff) -> sprintf "%s" (string_of_type_eff teff)
| NodeStaticArgEff (id, opeff) ->
- sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)
+ sprintf "%s" (string_of_node_key_rec opeff.node_key_eff)
(* for printing iterators *)
and static_arg2string lxm_opt (sa : static_arg_eff) =
@@ -269,7 +269,7 @@ and static_arg2string lxm_opt (sa : static_arg_eff) =
if
(snd opeff.node_key_eff) = []
then
- sprintf "%s" (string_of_node_key_iter opeff.lxm opeff.node_key_eff)
+ sprintf "%s" (string_of_node_key_iter opeff.lxm opeff.node_key_eff)
else
let np =
match lxm_opt with
@@ -331,22 +331,22 @@ and (string_of_by_pos_op_eff: by_pos_op_eff srcflagged -> val_exp_eff list -> st
let lxm = posop.src in
let str =
match posop.it,vel with
- | Predef_eff (Predef.IF_n,_), [ve1; ve2; ve3] ->
- " if " ^ (string_of_val_exp_eff ve1) ^
- " then " ^ (string_of_val_exp_eff ve2) ^
- " else " ^ (string_of_val_exp_eff ve3)
-
- | Predef_eff(op,sargs), vel ->
- if Predef.is_infix op then (
- match vel with
- | [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^
- " " ^ (string_of_val_exp_eff ve2)
- | _ -> assert false
- )
- else
- ((Predef.op2string op) ^
- (if sargs = [] then
+ | Predef_eff (Predef.IF_n,_), [ve1; ve2; ve3] ->
+ " if " ^ (string_of_val_exp_eff ve1) ^
+ " then " ^ (string_of_val_exp_eff ve2) ^
+ " else " ^ (string_of_val_exp_eff ve3)
+
+ | Predef_eff(op,sargs), vel ->
+ if Predef.is_infix op then (
+ match vel with
+ | [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " " ^ (Predef.op2string op) ^
+ " " ^ (string_of_val_exp_eff ve2)
+ | _ -> assert false
+ )
+ else
+ ((Predef.op2string op) ^
+ (if sargs = [] then
match op with
| Predef.ICONST_n _ | Predef.RCONST_n _ | Predef.NOT_n
| Predef.UMINUS_n | Predef.IUMINUS_n | Predef.RUMINUS_n
@@ -355,57 +355,57 @@ and (string_of_by_pos_op_eff: by_pos_op_eff srcflagged -> val_exp_eff list -> st
else
"<<" ^
(String.concat ", " (List.map (static_arg2string (Some lxm)) sargs))
- ^ ">>" ^ (tuple_par vel)))
-
- | CALL_eff nee, _ -> (
- if nee.it.def_eff = ExternEff then
- ((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
- else
- (* recursive node cannot be extern *)
- ((string_of_node_key_rec nee.it.node_key_eff) ^ (tuple_par vel))
- )
- | IDENT_eff idref, _ -> Ident.string_of_idref idref
- | CONST_eff (idref,pn), _ ->
+ ^ ">>" ^ (tuple_par vel)))
+
+ | CALL_eff nee, _ -> (
+ if nee.it.def_eff = ExternEff then
+ ((string_of_node_key_iter nee.src nee.it.node_key_eff) ^ (tuple_par vel))
+ else
+ (* recursive node cannot be extern *)
+ ((string_of_node_key_rec nee.it.node_key_eff) ^ (tuple_par vel))
+ )
+ | IDENT_eff idref, _ -> Ident.string_of_idref idref
+ | CONST_eff (idref,pn), _ ->
Ident.string_of_idref (
match Ident.pack_of_idref idref with
| Some _ -> idref
| None -> Ident.make_idref pn (Ident.of_idref idref)
)
- | PRE_eff, _ -> "pre " ^ (tuple vel)
- | ARROW_eff, [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " -> " ^ (string_of_val_exp_eff ve2)
- | FBY_eff, [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " fby " ^ (string_of_val_exp_eff ve2)
- | WHEN_eff _, [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " when " ^ (string_of_val_exp_eff ve2)
- | WHENOT_eff _, [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " when not " ^ (string_of_val_exp_eff ve2)
- | CURRENT_eff,_ -> "current " ^ (tuple vel)
- | TUPLE_eff,_ -> (tuple vel)
- | WITH_eff(ve),_ -> (string_of_val_exp_eff ve)
- | CONCAT_eff, [ve1; ve2] ->
- (string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
- | HAT_eff (i, ve), _ -> (string_of_val_exp_eff ve) ^ "^" ^ (string_of_int i)
- | ARRAY_eff, _ -> tuple_square vel
- | STRUCT_ACCESS_eff(id), [ve1] ->
- (string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)
-
- | ARRAY_ACCES_eff(i, type_eff), [ve1] ->
- (string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"
-
- | ARRAY_SLICE_eff(si_eff, type_eff), [ve1] ->
- (string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)
-
- | ARRAY_SLICE_eff(_,_), _ -> assert false (* todo *)
- | MERGE_eff _, _ -> assert false (* todo *)
- (* | ITERATOR_eff _, _ -> assert false (* todo *) *)
+ | PRE_eff, _ -> "pre " ^ (tuple vel)
+ | ARROW_eff, [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " -> " ^ (string_of_val_exp_eff ve2)
+ | FBY_eff, [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " fby " ^ (string_of_val_exp_eff ve2)
+ | WHEN_eff _, [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " when " ^ (string_of_val_exp_eff ve2)
+ | WHENOT_eff _, [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " when not " ^ (string_of_val_exp_eff ve2)
+ | CURRENT_eff,_ -> "current " ^ (tuple vel)
+ | TUPLE_eff,_ -> (tuple vel)
+ | WITH_eff(ve),_ -> (string_of_val_exp_eff ve)
+ | CONCAT_eff, [ve1; ve2] ->
+ (string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
+ | HAT_eff (i, ve), _ -> (string_of_val_exp_eff ve) ^ "^" ^ (string_of_int i)
+ | ARRAY_eff, _ -> tuple_square vel
+ | STRUCT_ACCESS_eff(id), [ve1] ->
+ (string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)
+
+ | ARRAY_ACCES_eff(i, type_eff), [ve1] ->
+ (string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"
+
+ | ARRAY_SLICE_eff(si_eff, type_eff), [ve1] ->
+ (string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)
+
+ | ARRAY_SLICE_eff(_,_), _ -> assert false (* todo *)
+ | MERGE_eff _, _ -> assert false (* todo *)
+ (* | ITERATOR_eff _, _ -> assert false (* todo *) *)
(* Cannot happen *)
- | ARROW_eff, _ -> assert false
- | FBY_eff, _ -> assert false
- | CONCAT_eff, _ -> assert false
- | STRUCT_ACCESS_eff(_), _ -> assert false
- | ARRAY_ACCES_eff(i, type_eff), _ -> assert false
+ | ARROW_eff, _ -> assert false
+ | FBY_eff, _ -> assert false
+ | CONCAT_eff, _ -> assert false
+ | STRUCT_ACCESS_eff(_), _ -> assert false
+ | ARRAY_ACCES_eff(i, type_eff), _ -> assert false
in
let do_not_parenthesize = function
| CONST_eff _,_
@@ -436,21 +436,21 @@ and string_of_val_exp_eff = function
| CallByNameEff(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
- | STRUCT_eff (pn,idref) -> prefix ^ (
+ | STRUCT_eff (pn,idref) -> prefix ^ (
match Ident.pack_of_idref idref with
| Some pn -> Ident.string_of_idref idref
| None ->
let idref = Ident.make_idref pn (Ident.of_idref idref) in
Ident.string_of_idref idref
)
- | STRUCT_anonymous_eff -> "") ^
- "{" ^ (String.concat ";"
- (List.map
- (fun (id,veff) ->
- (Ident.to_string id.it) ^ "=" ^ (string_of_val_exp_eff veff)
- )
- fl)) ^
- "}"
+ | STRUCT_anonymous_eff -> "") ^
+ "{" ^ (String.concat ";"
+ (List.map
+ (fun (id,veff) ->
+ (Ident.to_string id.it) ^ "=" ^ (string_of_val_exp_eff veff)
+ )
+ fl)) ^
+ "}"
@@ -459,17 +459,17 @@ and wrap_long_line str =
let str_list = Str.split (Str.regexp " ") str in
let new_str, reste =
List.fold_left
- (fun (accl, acc_str) str ->
- let new_acc_str = acc_str ^ " " ^ str in
- if
- String.length new_acc_str > 75
- then
- (accl ^ acc_str ^ "\n\t" , str)
- else
- (accl, new_acc_str)
- )
- ("","")
- str_list
+ (fun (accl, acc_str) str ->
+ let new_acc_str = acc_str ^ " " ^ str in
+ if
+ String.length new_acc_str > 75
+ then
+ (accl ^ acc_str ^ "\n\t" , str)
+ else
+ (accl, new_acc_str)
+ )
+ ("","")
+ str_list
in
new_str ^ " " ^ reste
@@ -492,8 +492,8 @@ and wrap_long_profile str =
if String.length str < 75 then str else
"\n"^(
Str.global_replace (Str.regexp "returns") "\nreturns"
- (Str.global_replace (Str.regexp "(") "(\n\t"
- (Str.global_replace (Str.regexp "; ") ";\n\t" str)))
+ (Str.global_replace (Str.regexp "(") "(\n\t"
+ (Str.global_replace (Str.regexp "; ") ";\n\t" str)))
and (profile_of_node_exp_eff: node_exp_eff -> string) =
fun neff ->
@@ -505,9 +505,9 @@ and (string_of_node_def : node_def_eff -> string list) =
| ExternEff
| AbstractEff -> []
| BodyEff node_body_eff ->
- List.append
- (List.map string_of_assert node_body_eff.asserts_eff)
- (List.map string_of_eq node_body_eff.eqs_eff)
+ List.append
+ (List.map string_of_assert node_body_eff.asserts_eff)
+ (List.map string_of_eq node_body_eff.eqs_eff)
@@ -516,8 +516,8 @@ and (type_decl: Ident.long -> type_eff -> string) =
fun tname teff ->
"type " ^ prefix ^ (long tname) ^
(match teff with
- | External_type_eff _ -> ";\n"
- | _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
+ | External_type_eff _ -> ";\n"
+ | _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
)
(* exported *)
@@ -525,14 +525,14 @@ and (const_decl: Ident.long -> const_eff -> string) =
fun tname ceff ->
let str = "const " ^ (long tname) in
(match ceff with
- | Extern_const_eff _ ->
+ | Extern_const_eff _ ->
str^":" ^ (string_of_type_eff (type_of_const_eff ceff))^ ";\n"
- | Enum_const_eff _ -> "" (* do not print those const *)
- | Struct_const_eff _ -> assert false
- | Array_const_eff _
- | Bool_const_eff _
- | Int_const_eff _
- | Real_const_eff _ -> str^" = " ^ (string_of_const_eff ceff)^ ";\n"
+ | Enum_const_eff _ -> "" (* do not print those const *)
+ | Struct_const_eff _ -> assert false
+ | Array_const_eff _
+ | Bool_const_eff _
+ | Int_const_eff _
+ | Real_const_eff _ -> str^" = " ^ (string_of_const_eff ceff)^ ";\n"
)
(* exported *)
@@ -544,17 +544,17 @@ and (node_of_node_exp_eff: node_exp_eff -> string) =
(string_of_node_key_rec neff.node_key_eff) ^
(profile_of_node_exp_eff neff)) ^
(match neff.def_eff with
- | ExternEff -> ""
- | AbstractEff -> ""
- | BodyEff _ ->
- ((match neff.loclist_eff with None -> "" | Some [] -> ""
- | Some l ->
- "var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n") ^
- "let\n " ^
- (String.concat "\n " (string_of_node_def neff.def_eff)) ^
- "\ntel\n-- end of node " ^
- (string_of_node_key_rec neff.node_key_eff) ^ "\n"
- )
+ | ExternEff -> ""
+ | AbstractEff -> ""
+ | BodyEff _ ->
+ ((match neff.loclist_eff with None -> "" | Some [] -> ""
+ | Some l ->
+ "var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n") ^
+ "let\n " ^
+ (String.concat "\n " (string_of_node_def neff.def_eff)) ^
+ "\ntel\n-- end of node " ^
+ (string_of_node_key_rec neff.node_key_eff) ^ "\n"
+ )
)
@@ -565,7 +565,7 @@ and string_of_clock2 (ck : clock_eff) =
match ck with
| BaseEff -> " on base"
| On(veff,ceff) ->" on " ^ (Ident.to_string veff) ^
- (string_of_clock2_aux ceff)
+ (string_of_clock2_aux ceff)
| ClockVar i -> "'a" ^ string_of_int i
in
match ck with
diff --git a/src/lxm.ml b/src/lxm.ml
index 261a730f..988bd617 100644
--- a/src/lxm.ml
+++ b/src/lxm.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 30/05/2008 (at 17:14) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:28) by Erwan Jahier> *)
(** Common to lus2lic and lic2loc *)
@@ -11,11 +11,11 @@ let new_line ( lexbuf ) = (
(* le type ``lexeme'', string + info source *)
type t = {
- _file : string ;
- _str : string ;
- _line : int ;
- _cstart : int ;
- _cend : int
+ _file : string ;
+ _str : string ;
+ _line : int ;
+ _cstart : int ;
+ _cend : int
}
let str x = (x._str)
@@ -63,10 +63,10 @@ let make ( lexbuf ) = (
let c2 = (Lexing.lexeme_end lexbuf - !Global.line_start_pos) in
last_lexeme :=
{ _str = s ;
- _file = !Global.current_file;
- _line = l;
- _cstart = c1 ;
- _cend = c2
+ _file = !Global.current_file;
+ _line = l;
+ _cstart = c1 ;
+ _cend = c2
};
!last_lexeme
)
diff --git a/src/main.ml b/src/main.ml
index 0fd1cf9b..565e7bc0 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/08/2008 (at 14:54) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:28) by Erwan Jahier> *)
(** Here follows a description of the different modules used by this lus2lic compiler.
@@ -112,8 +112,8 @@ let rec arg_list = [
and
parse_args () = (
Arg.parse arg_list (* liste des options *)
- Global.add_infile (* arg par defaut = fichier d'entree *)
- usage_msg (* message d'erreur *)
+ Global.add_infile (* arg par defaut = fichier d'entree *)
+ usage_msg (* message d'erreur *)
;
()
)
@@ -121,13 +121,13 @@ and
let test_lex ( lexbuf ) = (
let tk = ref (Lexer.lexer lexbuf) in (
while !tk <> Parser.TK_EOF do
- match (Lexer.token_code !tk) with
- ( co , lxm ) ->
- printf "%s : %15s = \"%s\"\n"
- (Lxm.position lxm) co (Lxm.str lxm) ;
- tk := (Lexer.lexer lexbuf)
+ match (Lexer.token_code !tk) with
+ ( co , lxm ) ->
+ printf "%s : %15s = \"%s\"\n"
+ (Lxm.position lxm) co (Lxm.str lxm) ;
+ tk := (Lexer.lexer lexbuf)
done
- )
+ )
)
(* Retourne un parse_tree *)
@@ -139,25 +139,25 @@ let lus_load lexbuf = (
(* Dump d'un packbody *)
let dump_body (pkg: SyntaxTree.packbody) = (
let os = Format.formatter_of_out_channel stdout in
- SyntaxTreeDump.packbody os pkg
+ SyntaxTreeDump.packbody os pkg
)
(* Dump d'un name-space, pack ou modele ... *)
let dump_ns (ns: SyntaxTree.pack_or_model) = (
let os = Format.formatter_of_out_channel stdout in
match ns with
- NSPack pf -> (
- (* Verbose.printf (lazy ("DUMP PACKDEF\n")); *)
- SyntaxTreeDump.packinfo os pf
- )
+ NSPack pf -> (
+ (* Verbose.printf (lazy ("DUMP PACKDEF\n")); *)
+ SyntaxTreeDump.packinfo os pf
+ )
| NSModel mf -> (
- (* Verbose.printf (lazy ("DUMP MODDEF\n")); *)
- SyntaxTreeDump.modelinfo os mf
- )
+ (* Verbose.printf (lazy ("DUMP MODDEF\n")); *)
+ SyntaxTreeDump.modelinfo os mf
+ )
)
(*
- Lance le parser et renvoie la liste name-spaces d'entrée.
+ Lance le parser et renvoie la liste name-spaces d'entrée.
Dans le cas d'un fichier sans package, on lui donne
comme nom le basename de infile.
*)
@@ -169,43 +169,43 @@ let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
fun infile_list ->
let (get_one_source : string -> string list * maybe_packed) =
fun infile ->
- let lexbuf = Global.lexbuf_of_file_name infile in
- match (lus_load lexbuf) with
- | PRPackBody(incl_files, pbdy) ->
- let nme =
- try Filename.chop_extension (Filename.basename infile)
- with _ -> print_string ("*** '"^infile^"': bad file name.\n"); exit 1
- in
- let pi =
- SyntaxTree.give_pack_this_name (Ident.pack_name_of_string nme) pbdy
- in
- incl_files, Unpacked (NSPack (Lxm.flagit pi (Lxm.dummy nme)))
- | PRPack_or_models(incl_files, nsl) -> incl_files, Packed nsl
+ let lexbuf = Global.lexbuf_of_file_name infile in
+ match (lus_load lexbuf) with
+ | PRPackBody(incl_files, pbdy) ->
+ let nme =
+ try Filename.chop_extension (Filename.basename infile)
+ with _ -> print_string ("*** '"^infile^"': bad file name.\n"); exit 1
+ in
+ let pi =
+ SyntaxTree.give_pack_this_name (Ident.pack_name_of_string nme) pbdy
+ in
+ incl_files, Unpacked (NSPack (Lxm.flagit pi (Lxm.dummy nme)))
+ | PRPack_or_models(incl_files, nsl) -> incl_files, Packed nsl
in
let rec (get_remaining_source_list : maybe_packed * string list * string list ->
- maybe_packed * string list * string list) =
+ maybe_packed * string list * string list) =
fun (maybe_pack, compiled, to_be_compiled) ->
- match to_be_compiled with
- | [] -> (maybe_pack, compiled, [])
- | infile::tail ->
- if List.mem infile compiled then
- get_remaining_source_list (maybe_pack, compiled, tail)
- else
- let included_files, pack = get_one_source infile in
- let new_maybe_pack =
- match maybe_pack, pack with
- | Unpacked _, _
- | _, Unpacked _ ->
- print_string ("old-style (un-packaged) lustre files can " ^
- " not be mixed with packages, nor be " ^
- " defined in more than 1 file.");
- exit 1
- | Packed l1, Packed l2 -> Packed (l1@l2)
- in
- get_remaining_source_list(
- new_maybe_pack,
- infile::compiled,
- tail@included_files)
+ match to_be_compiled with
+ | [] -> (maybe_pack, compiled, [])
+ | infile::tail ->
+ if List.mem infile compiled then
+ get_remaining_source_list (maybe_pack, compiled, tail)
+ else
+ let included_files, pack = get_one_source infile in
+ let new_maybe_pack =
+ match maybe_pack, pack with
+ | Unpacked _, _
+ | _, Unpacked _ ->
+ print_string ("old-style (un-packaged) lustre files can " ^
+ " not be mixed with packages, nor be " ^
+ " defined in more than 1 file.");
+ exit 1
+ | Packed l1, Packed l2 -> Packed (l1@l2)
+ in
+ get_remaining_source_list(
+ new_maybe_pack,
+ infile::compiled,
+ tail@included_files)
in
let first_file = assert (infile_list <> []); List.hd infile_list in
let included_files, first_pack = get_one_source first_file in
@@ -213,8 +213,8 @@ let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
(first_pack, [first_file], (List.tl infile_list) @ included_files)
in
match pack_list with
- | Packed l -> l
- | Unpacked pack -> [pack]
+ | Packed l -> l
+ | Unpacked pack -> [pack]
@@ -237,7 +237,7 @@ let main = (
let nsl = get_source_list !Global.infiles in
let main_node =
if !Global.main_node = "" then None else
- Some (Ident.idref_of_string !Global.main_node)
+ Some (Ident.idref_of_string !Global.main_node)
in
if !Global.outfile <> "" then Global.oc := open_out !Global.outfile;
Compile.doit nsl main_node;
@@ -246,33 +246,33 @@ let main = (
close_out !Global.oc
) with
Sys_error(s) ->
- prerr_string (s^"\n");
- my_exit 1
+ prerr_string (s^"\n");
+ my_exit 1
| Global_error s ->
- print_global_error s ;
- my_exit 1
+ print_global_error s ;
+ my_exit 1
| Parse_error ->
- print_compile_error (Lxm.last_made ()) "syntax error";
- my_exit 1
+ print_compile_error (Lxm.last_made ()) "syntax error";
+ my_exit 1
| Compile_error(lxm,msg) ->
- print_compile_error lxm msg ;
- my_exit 1
+ print_compile_error lxm msg ;
+ my_exit 1
| Assert_failure (file, line, col) ->
- prerr_string (
- "\n*** oops: an internal error occurred in file "^ file ^ ", line " ^
- (string_of_int line) ^ ", column " ^
- (string_of_int col) ^ "\n*** when compiling lustre program" ^
- (if List.length !Global.infiles > 1 then "s " else " ") ^
- (String.concat ", " !Global.infiles) ^ "\n") ;
- my_exit 2
-
- (* | Compile_node_error(nkey,lxm,msg) -> ( *)
- (* print_compile_node_error nkey lxm msg ; *)
- (* exit 1 *)
- (* ) *)
- (* | Global_node_error(nkey,msg) -> ( *)
- (* print_global_node_error nkey msg ; *)
- (* exit 1 *)
- (* ) *)
+ prerr_string (
+ "\n*** oops: an internal error occurred in file "^ file ^ ", line " ^
+ (string_of_int line) ^ ", column " ^
+ (string_of_int col) ^ "\n*** when compiling lustre program" ^
+ (if List.length !Global.infiles > 1 then "s " else " ") ^
+ (String.concat ", " !Global.infiles) ^ "\n") ;
+ my_exit 2
+
+ (* | Compile_node_error(nkey,lxm,msg) -> ( *)
+ (* print_compile_node_error nkey lxm msg ; *)
+ (* exit 1 *)
+ (* ) *)
+ (* | Global_node_error(nkey,msg) -> ( *)
+ (* print_global_node_error nkey msg ; *)
+ (* exit 1 *)
+ (* ) *)
)
diff --git a/src/parser.mly b/src/parser.mly
index 93ad391e..62533452 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -128,7 +128,7 @@ open ParserUtils
%%
/*-------------------------------------------------------
- GRAMMAR
+ GRAMMAR
---------------------------------------------------------
NOTES ON THE CODE:
@@ -150,42 +150,42 @@ or a list of pack/model declaration
*/
sxLusFile:
- /* WARNING ! il faut remettre la liste à l'endroit */
- sxIncludeList sxPackBody TK_EOF
- {
- SyntaxTree.PRPackBody($1, $2)
- }
-| sxIncludeList sxPackList TK_EOF
- {
- SyntaxTree.PRPack_or_models ($1, List.rev $2)
- }
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ sxIncludeList sxPackBody TK_EOF
+ {
+ SyntaxTree.PRPackBody($1, $2)
+ }
+| sxIncludeList sxPackList TK_EOF
+ {
+ SyntaxTree.PRPack_or_models ($1, List.rev $2)
+ }
;
sxPackList:
- sxOnePack
- { [$1] }
-| sxPackList sxOnePack
- { $2::$1 }
+ sxOnePack
+ { [$1] }
+| sxPackList sxOnePack
+ { $2::$1 }
;
sxOnePack:
- sxModelDecl
- { SyntaxTree.NSModel $1 }
-| sxPackDecl
- { SyntaxTree.NSPack $1 }
-| sxPackEq
- { SyntaxTree.NSPack $1 }
+ sxModelDecl
+ { SyntaxTree.NSModel $1 }
+| sxPackDecl
+ { SyntaxTree.NSPack $1 }
+| sxPackEq
+ { SyntaxTree.NSPack $1 }
;
sxInclude:
- TK_INCLUDE TK_STRING
- { (Lxm.str $2) }
+ TK_INCLUDE TK_STRING
+ { (Lxm.str $2) }
;
sxIncludeList:
- { [] }
-| sxInclude sxIncludeList
- { $1::$2 }
+ { [] }
+| sxInclude sxIncludeList
+ { $1::$2 }
;
/*
@@ -194,255 +194,255 @@ que syntaxiquement, on n'autorise pas n'importe quoi ...
*/
sxProvides:
- /* nada */
- { None }
-/* | TK_PROVIDES sxStaticParamList TK_SEMICOL */
-| TK_PROVIDES sxProvideList TK_SEMICOL
- { Some (List.rev $2) }
+ /* nada */
+ { None }
+/* | TK_PROVIDES sxStaticParamList TK_SEMICOL */
+| TK_PROVIDES sxProvideList TK_SEMICOL
+ { Some (List.rev $2) }
;
sxProvideList: sxOneProvide
- { [$1] }
- | sxProvideList TK_SEMICOL sxOneProvide
- { $3::$1 }
- ;
+ { [$1] }
+ | sxProvideList TK_SEMICOL sxOneProvide
+ { $3::$1 }
+ ;
sxConstDefOpt:
- { None}
-| TK_EQ sxExpression
- {
- Some $2
- }
+ { None}
+| TK_EQ sxExpression
+ {
+ Some $2
+ }
sxOneProvide:
- /* constante abstraite */
- TK_CONST sxIdent TK_COLON sxType sxConstDefOpt
- {
- Lxm.flagit
- (ConstInfo (ExternalConst (Lxm.id $2, $4, $5)))
- $2
- }
- /* noeud abstrait */
-| TK_NODE sxIdent sxParams TK_RETURNS sxParams
- {
- treat_abstract_node true $2 $3 $5
- }
- /* fonction abstraite */
-| TK_FUNCTION sxIdent sxParams TK_RETURNS sxParams
- {
- treat_abstract_node false $2 $3 $5
- }
- /* type abstrait ... */
-| TK_TYPE sxIdent
- {
- Lxm.flagit
- (TypeInfo (ExternalType (Lxm.id $2)))
- $2
- }
- /* un alias sur type immédiat */
-| TK_TYPE sxIdent TK_EQ sxType
- {
- Lxm.flagit
- (TypeInfo (AliasedType (Lxm.id $2, $4)))
- $2
- }
- /* type énuméré */
- /* WARNING ! la liste n'est pas à l'endroit */
-| TK_TYPE sxIdent TK_EQ TK_ENUM TK_OPEN_BRACE sxIdentList TK_CLOSE_BRACE
- {
- let fields = List.rev_map lexeme_to_ident_flagged $6 in
- Lxm.flagit
- (TypeInfo (EnumType (Lxm.id $2, fields)))
- $2
- }
- /* type structure à champs nommés */
- /* WARNING ! la liste est déjà à l'endroit */
-| TK_TYPE sxIdent TK_EQ opt_TK_STRUCT
+ /* constante abstraite */
+ TK_CONST sxIdent TK_COLON sxType sxConstDefOpt
+ {
+ Lxm.flagit
+ (ConstInfo (ExternalConst (Lxm.id $2, $4, $5)))
+ $2
+ }
+ /* noeud abstrait */
+| TK_NODE sxIdent sxParams TK_RETURNS sxParams
+ {
+ treat_abstract_node true $2 $3 $5
+ }
+ /* fonction abstraite */
+| TK_FUNCTION sxIdent sxParams TK_RETURNS sxParams
+ {
+ treat_abstract_node false $2 $3 $5
+ }
+ /* type abstrait ... */
+| TK_TYPE sxIdent
+ {
+ Lxm.flagit
+ (TypeInfo (ExternalType (Lxm.id $2)))
+ $2
+ }
+ /* un alias sur type immédiat */
+| TK_TYPE sxIdent TK_EQ sxType
+ {
+ Lxm.flagit
+ (TypeInfo (AliasedType (Lxm.id $2, $4)))
+ $2
+ }
+ /* type énuméré */
+ /* WARNING ! la liste n'est pas à l'endroit */
+| TK_TYPE sxIdent TK_EQ TK_ENUM TK_OPEN_BRACE sxIdentList TK_CLOSE_BRACE
+ {
+ let fields = List.rev_map lexeme_to_ident_flagged $6 in
+ Lxm.flagit
+ (TypeInfo (EnumType (Lxm.id $2, fields)))
+ $2
+ }
+ /* type structure à champs nommés */
+ /* WARNING ! la liste est déjà à l'endroit */
+| TK_TYPE sxIdent TK_EQ opt_TK_STRUCT
TK_OPEN_BRACE sxTypedValuedIdents TK_CLOSE_BRACE
- {
- let sti = make_struct_type_info $2 $6 in
- Lxm.flagit
- (TypeInfo (StructType sti))
- $2
- }
+ {
+ let sti = make_struct_type_info $2 $6 in
+ Lxm.flagit
+ (TypeInfo (StructType sti))
+ $2
+ }
;
sxModelDecl:
- TK_MODEL sxIdent
- sxUses
- /* TK_NEEDS sxPackParamList TK_SEMICOL */
- TK_NEEDS sxStaticParamList TK_SEMICOL
- sxProvides
- TK_BODY
- sxPackBody
- TK_END
- {
- let mdecl = {
- mo_name = (Ident.pack_name_of_string (Lxm.str $2));
- mo_uses = $3 ;
- mo_needs = (List.rev $5) ;
- mo_provides = $7 ;
- mo_body = $9;
- } in
- {it = mdecl; src = $2 }
- }
+ TK_MODEL sxIdent
+ sxUses
+ /* TK_NEEDS sxPackParamList TK_SEMICOL */
+ TK_NEEDS sxStaticParamList TK_SEMICOL
+ sxProvides
+ TK_BODY
+ sxPackBody
+ TK_END
+ {
+ let mdecl = {
+ mo_name = (Ident.pack_name_of_string (Lxm.str $2));
+ mo_uses = $3 ;
+ mo_needs = (List.rev $5) ;
+ mo_provides = $7 ;
+ mo_body = $9;
+ } in
+ {it = mdecl; src = $2 }
+ }
;
sxPackDecl:
- TK_PACKAGE sxIdent
- sxUses
- sxProvides
- TK_BODY
- sxPackBody
- TK_END
- {
- let pdef = PackGiven {
- pg_uses = $3 ;
- pg_provides = $4 ;
- pg_body = $6;
- } in
- let pdecl = {
- pa_name = (Ident.pack_name_of_string (Lxm.str $2));
- pa_def = pdef;
- } in
- {it = pdecl; src = $2 }
- }
+ TK_PACKAGE sxIdent
+ sxUses
+ sxProvides
+ TK_BODY
+ sxPackBody
+ TK_END
+ {
+ let pdef = PackGiven {
+ pg_uses = $3 ;
+ pg_provides = $4 ;
+ pg_body = $6;
+ } in
+ let pdecl = {
+ pa_name = (Ident.pack_name_of_string (Lxm.str $2));
+ pa_def = pdef;
+ } in
+ {it = pdecl; src = $2 }
+ }
;
/* pack params are identical to node static Packparams (?) */
/*
sxPackParamList:
- sxStaticParamList
- { $1 }
+ sxStaticParamList
+ { $1 }
;
*/
sxUses:
- /* nada */
- { [] }
-| TK_USES sxIdentList TK_SEMICOL
- {
- List.rev_map lexeme_to_pack_name_flagged $2
- }
+ /* nada */
+ { [] }
+| TK_USES sxIdentList TK_SEMICOL
+ {
+ List.rev_map lexeme_to_pack_name_flagged $2
+ }
;
/* */
sxEq_or_Is:
-| TK_EQ
- {}
-| TK_IS
- {}
+| TK_EQ
+ {}
+| TK_IS
+ {}
/* I don't like by-pos notation, but keep it
- for backward compatibility
+ for backward compatibility
*/
sxPackEq:
- TK_PACKAGE sxIdent sxEq_or_Is sxIdent TK_OPEN_PAR
- sxStaticArgList
- TK_CLOSE_PAR TK_SEMICOL
- {
- let pdef = PackInstance {
- pi_model = (Lxm.id $4);
- pi_args = (List.rev $6);
- } in
- let pa = {
- pa_name = (Ident.pack_name_of_string (Lxm.str $2));
- pa_def = pdef;
- } in
- {it = pa; src = $2 }
- }
+ TK_PACKAGE sxIdent sxEq_or_Is sxIdent TK_OPEN_PAR
+ sxStaticArgList
+ TK_CLOSE_PAR TK_SEMICOL
+ {
+ let pdef = PackInstance {
+ pi_model = (Lxm.id $4);
+ pi_args = (List.rev $6);
+ } in
+ let pa = {
+ pa_name = (Ident.pack_name_of_string (Lxm.str $2));
+ pa_def = pdef;
+ } in
+ {it = pa; src = $2 }
+ }
;
/* sxPackBody :
- les informations collectées dans les tables
- sont figées, et on remet les tables à 0 ...
+ les informations collectées dans les tables
+ sont figées, et on remet les tables à 0 ...
*/
sxPackBody:
- sxDeclList
- {
- let res = SyntaxTree.make_packbody
- const_table type_table node_table (List.rev !def_list) in
- (* clean all ... *)
- Hashtbl.clear const_table ;
- Hashtbl.clear type_table ;
- Hashtbl.clear node_table ;
- def_list := [] ;
- res
- }
+ sxDeclList
+ {
+ let res = SyntaxTree.make_packbody
+ const_table type_table node_table (List.rev !def_list) in
+ (* clean all ... *)
+ Hashtbl.clear const_table ;
+ Hashtbl.clear type_table ;
+ Hashtbl.clear node_table ;
+ def_list := [] ;
+ res
+ }
;
/* sxDeclarations */
sxDeclList: sxOneDecl
- { }
- | sxDeclList sxOneDecl
- { }
- ;
+ { }
+ | sxDeclList sxOneDecl
+ { }
+ ;
sxOneDecl:
- sxConstDecl
- { }
- | sxTypeDecl
- { }
- | sxExtNodeDecl
- { }
- | sxNodeDecl
- { }
- ;
+ sxConstDecl
+ { }
+ | sxTypeDecl
+ { }
+ | sxExtNodeDecl
+ { }
+ | sxNodeDecl
+ { }
+ ;
/* sxIdentifiers and lists */
sxIdentRef :
- /* simple or long ... */
- TK_IDENT
- { idref_of_lxm $1 }
-| TK_LONGIDENT
- { idref_of_lxm $1 }
+ /* simple or long ... */
+ TK_IDENT
+ { idref_of_lxm $1 }
+| TK_LONGIDENT
+ { idref_of_lxm $1 }
;
/* sxIdentifiers and lists */
sxIdent: TK_IDENT sxPragma
- { $1 }
- ;
+ { $1 }
+ ;
sxIdentList: sxIdent
- { [$1] }
- | sxIdentList TK_COMA sxIdent
- { $3::$1 }
- ;
+ { [$1] }
+ | sxIdentList TK_COMA sxIdent
+ { $3::$1 }
+ ;
sxTypedIdentsList: sxTypedIdents
- { [ $1 ] }
- | sxTypedIdentsList TK_SEMICOL sxTypedIdents
- { $3::$1 }
- ;
+ { [ $1 ] }
+ | sxTypedIdentsList TK_SEMICOL sxTypedIdents
+ { $3::$1 }
+ ;
sxTypedIdents: sxIdentList TK_COLON sxType
- /* WARNING ! il faut remettre la liste à l'endroit */
- { ((List.rev $1), $3 ) }
- ;
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ { ((List.rev $1), $3 ) }
+ ;
sxTypedValuedIdents: sxTypedValuedIdent
- { $1 }
- | sxTypedValuedIdents TK_SEMICOL sxTypedValuedIdent
- { List.append $1 $3 }
- ;
+ { $1 }
+ | sxTypedValuedIdents TK_SEMICOL sxTypedValuedIdent
+ { List.append $1 $3 }
+ ;
sxTypedValuedIdent :
- /* Les listes d'idents en partie gauche sont
- acceptées pour les idents SANS valeur
- */
- sxIdent TK_COLON sxType
- { (id_valopt_list_of_id_list [$1] $3 ) }
- | sxIdent TK_COMA sxIdentList TK_COLON sxType
- { (id_valopt_list_of_id_list ($1::(List.rev $3)) $5) }
- /* Mais pas pour les constantes définies :
- */
- | sxIdent TK_COLON sxType TK_EQ sxExpression
- { [id_valopt_of_id_val $1 $3 $5] }
+ /* Les listes d'idents en partie gauche sont
+ acceptées pour les idents SANS valeur
+ */
+ sxIdent TK_COLON sxType
+ { (id_valopt_list_of_id_list [$1] $3 ) }
+ | sxIdent TK_COMA sxIdentList TK_COLON sxType
+ { (id_valopt_list_of_id_list ($1::(List.rev $3)) $5) }
+ /* Mais pas pour les constantes définies :
+ */
+ | sxIdent TK_COLON sxType TK_EQ sxExpression
+ { [id_valopt_of_id_val $1 $3 $5] }
;
@@ -464,59 +464,59 @@ sxOneConstDecl:
| sxIdent TK_COLON sxType TK_EQ sxExpression
{ (treat_defined_const $1 (Some $3) $5) }
| sxIdent TK_EQ sxExpression
- { (treat_defined_const $1 (None) $3 ) }
- ;
+ { (treat_defined_const $1 (None) $3 ) }
+ ;
/* types */
sxTypeDecl: TK_TYPE sxTypeDeclList
- {}
- ;
+ {}
+ ;
sxTypeDeclList: sxOneTypeDecl TK_SEMICOL
- {}
- | sxTypeDeclList sxOneTypeDecl TK_SEMICOL
- {}
- ;
+ {}
+ | sxTypeDeclList sxOneTypeDecl TK_SEMICOL
+ {}
+ ;
sxOneTypeDecl:
- /* liste de types abstraits (externes) */
- sxIdentList
- { treat_external_type_list (List.rev $1) }
- /* un alias sur type immédiat */
- | sxIdent TK_EQ sxType
- { treat_aliased_type $1 $3 }
- /* type énuméré */
- /* WARNING ! il faut remettre la liste à l'endroit */
- | sxIdent TK_EQ TK_ENUM TK_OPEN_BRACE sxIdentList TK_CLOSE_BRACE
- {
- treat_enum_type $1 (List.rev $5)
- }
- /* type structure à champs nommés */
- /* WARNING ! la liste est déjà à l'endroit */
- | sxIdent TK_EQ opt_TK_STRUCT TK_OPEN_BRACE sxTypedValuedIdents TK_CLOSE_BRACE
- { treat_struct_type $1 $5 }
- ;
+ /* liste de types abstraits (externes) */
+ sxIdentList
+ { treat_external_type_list (List.rev $1) }
+ /* un alias sur type immédiat */
+ | sxIdent TK_EQ sxType
+ { treat_aliased_type $1 $3 }
+ /* type énuméré */
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ | sxIdent TK_EQ TK_ENUM TK_OPEN_BRACE sxIdentList TK_CLOSE_BRACE
+ {
+ treat_enum_type $1 (List.rev $5)
+ }
+ /* type structure à champs nommés */
+ /* WARNING ! la liste est déjà à l'endroit */
+ | sxIdent TK_EQ opt_TK_STRUCT TK_OPEN_BRACE sxTypedValuedIdents TK_CLOSE_BRACE
+ { treat_struct_type $1 $5 }
+ ;
/* COMPATIBILITY : "struct" keyword is optional */
opt_TK_STRUCT:
- /* nothing */ {}
-| TK_STRUCT {}
+ /* nothing */ {}
+| TK_STRUCT {}
;
-
+
/* Notation de type "immédiat" */
sxType:
- /* prédéfini */
- TK_BOOL { {src=$1; it=Bool_type_exp } }
- | TK_INT { {src=$1; it=Int_type_exp } }
- | TK_REAL { {src=$1; it=Real_type_exp } }
- /* ref à un type nommé */
- | sxIdentRef { {src=$1.src; it= Named_type_exp $1.it } }
- /* ou tableau immédiat */
- | sxType TK_HAT sxExpression
- { {src=$2; it=Array_type_exp ($1 , $3) } }
- ;
+ /* prédéfini */
+ TK_BOOL { {src=$1; it=Bool_type_exp } }
+ | TK_INT { {src=$1; it=Int_type_exp } }
+ | TK_REAL { {src=$1; it=Real_type_exp } }
+ /* ref à un type nommé */
+ | sxIdentRef { {src=$1.src; it= Named_type_exp $1.it } }
+ /* ou tableau immédiat */
+ | sxType TK_HAT sxExpression
+ { {src=$2; it=Array_type_exp ($1 , $3) } }
+ ;
/* extern nodes */
@@ -525,7 +525,7 @@ sxExtNodeDecl:
TK_EXTERN TK_FUNCTION sxIdent sxParams TK_RETURNS sxParams sxOptSemicol
{ treat_external_node false $3 $4 $6 }
| TK_EXTERN TK_NODE sxIdent sxParams TK_RETURNS sxParams sxOptSemicol
- { treat_external_node true $3 $4 $6 }
+ { treat_external_node true $3 $4 $6 }
;
/* noeuds */
@@ -534,137 +534,137 @@ sxNodeDecl: sxLocalNode {};
sxLocalNode:
| TK_NODE sxIdent sxStaticParams sxParams TK_RETURNS sxParams sxPragma sxOptSemicol
- sxLocals sxBody sxOptEndNode
- { treat_node_decl true $2 $3 $4 $6 $9 $7 (fst $10) (snd $10) }
+ sxLocals sxBody sxOptEndNode
+ { treat_node_decl true $2 $3 $4 $6 $9 $7 (fst $10) (snd $10) }
| TK_FUNCTION sxIdent sxStaticParams sxParams TK_RETURNS sxParams sxPragma sxOptSemicol
- sxLocals sxBody sxOptEndNode
- { treat_node_decl false $2 $3 $4 $6 $9 $7 (fst $10) (snd $10) }
+ sxLocals sxBody sxOptEndNode
+ { treat_node_decl false $2 $3 $4 $6 $9 $7 (fst $10) (snd $10) }
| TK_NODE sxIdent sxStaticParams sxNodeProfileOpt TK_EQ sxEffectiveNode sxOptSemicol
- { treat_node_alias true $2 $3 $4 $6 } ;
+ { treat_node_alias true $2 $3 $4 $6 } ;
| TK_FUNCTION sxIdent sxStaticParams sxNodeProfileOpt TK_EQ sxEffectiveNode sxOptSemicol
- { treat_node_alias false $2 $3 $4 $6 } ;
+ { treat_node_alias false $2 $3 $4 $6 } ;
sxNodeProfileOpt :
- /* nada */
- { None }
-| sxParams TK_RETURNS sxParams
- {
- let invars = clocked_ids_to_var_infos VarInput $1 in
- let outvars = clocked_ids_to_var_infos VarOutput $3 in
- Some (invars, outvars)
- }
+ /* nada */
+ { None }
+| sxParams TK_RETURNS sxParams
+ {
+ let invars = clocked_ids_to_var_infos VarInput $1 in
+ let outvars = clocked_ids_to_var_infos VarOutput $3 in
+ Some (invars, outvars)
+ }
;
sxStaticParams: /*rien*/
- { [] }
- | TK_OPEN_STATIC_PAR sxStaticParamList TK_CLOSE_STATIC_PAR
- { (List.rev $2) }
+ { [] }
+ | TK_OPEN_STATIC_PAR sxStaticParamList TK_CLOSE_STATIC_PAR
+ { (List.rev $2) }
;
sxStaticParamList:
- sxStaticParam
- { [$1] }
- | sxStaticParamList TK_SEMICOL sxStaticParam
- { $3::$1 }
- ;
+ sxStaticParam
+ { [$1] }
+ | sxStaticParamList TK_SEMICOL sxStaticParam
+ { $3::$1 }
+ ;
sxStaticParam:
- TK_TYPE sxIdent
- { {it=(StaticParamType (Lxm.id $2)); src=$2} }
- | TK_CONST sxIdent TK_COLON sxType
- { {it=(StaticParamConst (Lxm.id $2 , $4)); src=$2} }
- | TK_NODE sxIdent sxParams TK_RETURNS sxParams
- {
- let invars = clocked_ids_to_var_infos VarInput $3 in
- let outvars = clocked_ids_to_var_infos VarOutput $5 in
- let xn = StaticParamNode (
- Lxm.id $2,
- invars,
- outvars,
- true
- ) in
- Lxm.flagit xn $2
- }
- | TK_FUNCTION sxIdent sxParams TK_RETURNS sxParams
- {
- let invars = clocked_ids_to_var_infos VarInput $3 in
- let outvars = clocked_ids_to_var_infos VarOutput $5 in
- let xn = StaticParamNode (
- Lxm.id $2,
- invars,
- outvars,
- false
- ) in
- Lxm.flagit xn $2
- }
+ TK_TYPE sxIdent
+ { {it=(StaticParamType (Lxm.id $2)); src=$2} }
+ | TK_CONST sxIdent TK_COLON sxType
+ { {it=(StaticParamConst (Lxm.id $2 , $4)); src=$2} }
+ | TK_NODE sxIdent sxParams TK_RETURNS sxParams
+ {
+ let invars = clocked_ids_to_var_infos VarInput $3 in
+ let outvars = clocked_ids_to_var_infos VarOutput $5 in
+ let xn = StaticParamNode (
+ Lxm.id $2,
+ invars,
+ outvars,
+ true
+ ) in
+ Lxm.flagit xn $2
+ }
+ | TK_FUNCTION sxIdent sxParams TK_RETURNS sxParams
+ {
+ let invars = clocked_ids_to_var_infos VarInput $3 in
+ let outvars = clocked_ids_to_var_infos VarOutput $5 in
+ let xn = StaticParamNode (
+ Lxm.id $2,
+ invars,
+ outvars,
+ false
+ ) in
+ Lxm.flagit xn $2
+ }
;
/* Le "." à la fin des noeuds est une fioriture historique,
- On accepte donc '.' ';' ou rien du tout !
+ On accepte donc '.' ';' ou rien du tout !
*/
sxOptEndNode:
- TK_DOT
- {}
- | sxOptSemicol
- {}
- ;
+ TK_DOT
+ {}
+ | sxOptSemicol
+ {}
+ ;
/* Aucune difference entre params d'entrée et les autres */
/* params de sortie */
sxParams:
- /* rien */
- TK_OPEN_PAR TK_CLOSE_PAR
- { [] }
- |
- TK_OPEN_PAR sxVarDeclList sxOptSemicol TK_CLOSE_PAR
- /* WARNING ! il faut remettre la liste à l'endroit */
- { (List.rev $2) }
- ;
+ /* rien */
+ TK_OPEN_PAR TK_CLOSE_PAR
+ { [] }
+ |
+ TK_OPEN_PAR sxVarDeclList sxOptSemicol TK_CLOSE_PAR
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ { (List.rev $2) }
+ ;
/* variables locales */
-sxLocals: /* empty */
- { [] }
- | TK_VAR sxVarDeclList TK_SEMICOL
- /* WARNING ! il faut remettre la liste à l'endroit */
- { (List.rev $2) }
- ;
+sxLocals: /* empty */
+ { [] }
+ | TK_VAR sxVarDeclList TK_SEMICOL
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ { (List.rev $2) }
+ ;
/* liste de déclarations de vars typées et clockées */
sxVarDeclList: sxVarDecl
- { [$1] }
- | sxVarDeclList TK_SEMICOL sxVarDecl
- { $3::$1 }
- ;
+ { [$1] }
+ | sxVarDeclList TK_SEMICOL sxVarDecl
+ { $3::$1 }
+ ;
/* déclaration de vars éventuellement clockées */
sxVarDecl:
- /*
- Pas de clock : sous-entendu sur la base
- exemple: x, ..., z : type
- */
- sxTypedIdents
- {
- ([$1], Base)
- }
- |
- /*
- Clock explicite sur UNE seule liste d'idents typés
- exemple: x, ..., z : type when clock
- */
- sxTypedIdents TK_WHEN sxIdent
- {
- ([$1], (NamedClock {it=Lxm.id $3; src = $3} ))
- }
- |
- /*
- Clock explicite sur PLUSIEURS listes d'idents typés
- exemple: (x,..,z : t1 ; a,...,b : t2) when clock
- */
- TK_OPEN_PAR sxTypedIdentsList TK_CLOSE_PAR TK_WHEN sxIdent
- /* WARNING ! il faut remettre la liste à l'endroit */
- {
- ( (List.rev $2), (NamedClock {it=Lxm.id $5; src=$5} ) )
- }
- ;
+ /*
+ Pas de clock : sous-entendu sur la base
+ exemple: x, ..., z : type
+ */
+ sxTypedIdents
+ {
+ ([$1], Base)
+ }
+ |
+ /*
+ Clock explicite sur UNE seule liste d'idents typés
+ exemple: x, ..., z : type when clock
+ */
+ sxTypedIdents TK_WHEN sxIdent
+ {
+ ([$1], (NamedClock {it=Lxm.id $3; src = $3} ))
+ }
+ |
+ /*
+ Clock explicite sur PLUSIEURS listes d'idents typés
+ exemple: (x,..,z : t1 ; a,...,b : t2) when clock
+ */
+ TK_OPEN_PAR sxTypedIdentsList TK_CLOSE_PAR TK_WHEN sxIdent
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ {
+ ( (List.rev $2), (NamedClock {it=Lxm.id $5; src=$5} ) )
+ }
+ ;
/* Corps d'un noeud */
/*
@@ -672,292 +672,292 @@ Retourne un couple (assertions list, equations list)
*/
sxBody:
TK_LET TK_TEL
- { ([], []) }
- | TK_LET sxEquationList TK_TEL
- /* WARNING ! il faut remettre les listes à l'endroit */
- { (List.rev (fst $2) , List.rev (snd $2)) }
- ;
+ { ([], []) }
+ | TK_LET sxEquationList TK_TEL
+ /* WARNING ! il faut remettre les listes à l'endroit */
+ { (List.rev (fst $2) , List.rev (snd $2)) }
+ ;
/* Equations */
sxEquationList: sxEquation
- { $1 }
- | sxPragma sxEquation
- { $2 }
- | sxEquationList sxEquation
- {
- ( (fst $2) @ (fst $1) , (snd $2) @ (snd $1) )
- }
- ;
+ { $1 }
+ | sxPragma sxEquation
+ { $2 }
+ | sxEquationList sxEquation
+ {
+ ( (fst $2) @ (fst $1) , (snd $2) @ (snd $1) )
+ }
+ ;
sxEquation: TK_ASSERT sxExpression TK_SEMICOL
- {
- ( [ {src = $1; it = $2} ] , [] )
- }
- | sxLeft TK_EQ sxExpression TK_SEMICOL
- {
- ( [] , [ {src = $2; it = ($1, $3) } ] )
- }
- ;
+ {
+ ( [ {src = $1; it = $2} ] , [] )
+ }
+ | sxLeft TK_EQ sxExpression TK_SEMICOL
+ {
+ ( [] , [ {src = $2; it = ($1, $3) } ] )
+ }
+ ;
/* partie gauche d'equation */
sxLeft: sxLeftItemList
- /* WARNING ! il faut remettre la liste à l'endroit */
- { (List.rev $1) }
- | TK_OPEN_PAR sxLeftItemList TK_CLOSE_PAR
- /* WARNING ! il faut remettre la liste à l'endroit */
- { (List.rev $2) }
- ;
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ { (List.rev $1) }
+ | TK_OPEN_PAR sxLeftItemList TK_CLOSE_PAR
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ { (List.rev $2) }
+ ;
sxLeftItemList: sxLeftItem
- { [$1] }
- | sxLeftItemList TK_COMA sxLeftItem
- { $3::$1 }
- ;
+ { [$1] }
+ | sxLeftItemList TK_COMA sxLeftItem
+ { $3::$1 }
+ ;
sxLeftItem: sxIdent
- { LeftVar ( {src = $1; it = Lxm.id $1} ) }
- | sxFieldLeftItem
- { $1 }
- | sxTableLeftItem
- { $1 }
- ;
+ { LeftVar ( {src = $1; it = Lxm.id $1} ) }
+ | sxFieldLeftItem
+ { $1 }
+ | sxTableLeftItem
+ { $1 }
+ ;
sxFieldLeftItem: sxLeftItem TK_DOT sxIdent
- { LeftField ($1 , {src = $3; it = Lxm.id $3} ) }
- ;
+ { LeftField ($1 , {src = $3; it = Lxm.id $3} ) }
+ ;
sxTableLeftItem:
- sxLeftItem TK_OPEN_BRACKET sxExpression TK_CLOSE_BRACKET
- { LeftArray ($1 , {src = $2; it = $3}) }
- | sxLeftItem TK_OPEN_BRACKET sxSelect TK_CLOSE_BRACKET
- { LeftSlice ($1, $3 ) }
- ;
+ sxLeftItem TK_OPEN_BRACKET sxExpression TK_CLOSE_BRACKET
+ { LeftArray ($1 , {src = $2; it = $3}) }
+ | sxLeftItem TK_OPEN_BRACKET sxSelect TK_CLOSE_BRACKET
+ { LeftSlice ($1, $3 ) }
+ ;
/* partie droite d'equation (expression) */
sxExpression:
- /* zéroaires */
- sxConstant { $1 }
- | sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
- /* unaires */
- | TK_NOT sxExpression { unexp_predef $1 NOT_n $2 }
- | TK_MINUS sxExpression %prec TK_UMINUS
- { unexp_predef $1 UMINUS_n $2 }
- | TK_PRE sxExpression { unexp $1 PRE_n $2 }
- | TK_CURRENT sxExpression { unexp $1 CURRENT_n $2 }
- | TK_INT sxExpression { unexp_predef $1 REAL2INT_n $2 }
- | TK_REAL sxExpression { unexp_predef $1 INT2REAL_n $2 }
- /* binaires */
- | sxExpression TK_FBY sxExpression { binexp $2 FBY_n $1 $3 }
- | sxExpression TK_ARROW sxExpression { binexp $2 ARROW_n $1 $3 }
- | sxExpression TK_WHEN sxExpression { binexp $2 WHEN_n $1 $3 }
- | sxExpression TK_AND sxExpression { binexp_predef $2 AND_n $1 $3 }
- | sxExpression TK_OR sxExpression { binexp_predef $2 OR_n $1 $3 }
- | sxExpression TK_XOR sxExpression { binexp_predef $2 XOR_n $1 $3 }
- | sxExpression TK_IMPL sxExpression { binexp_predef $2 IMPL_n $1 $3 }
- | sxExpression TK_EQ sxExpression { binexp_predef $2 EQ_n $1 $3 }
- | sxExpression TK_NEQ sxExpression { binexp_predef $2 NEQ_n $1 $3 }
- | sxExpression TK_LT sxExpression { binexp_predef $2 LT_n $1 $3 }
- | sxExpression TK_LTE sxExpression { binexp_predef $2 LTE_n $1 $3 }
- | sxExpression TK_GT sxExpression { binexp_predef $2 GT_n $1 $3 }
- | sxExpression TK_GTE sxExpression { binexp_predef $2 GTE_n $1 $3 }
- | sxExpression TK_DIV sxExpression { binexp_predef $2 DIV_n $1 $3 }
- | sxExpression TK_MOD sxExpression { binexp_predef $2 MOD_n $1 $3 }
- | sxExpression TK_MINUS sxExpression { binexp_predef $2 MINUS_n $1 $3 }
- | sxExpression TK_PLUS sxExpression { binexp_predef $2 PLUS_n $1 $3 }
- | sxExpression TK_SLASH sxExpression { binexp_predef $2 SLASH_n $1 $3 }
- | sxExpression TK_STAR sxExpression { binexp_predef $2 TIMES_n $1 $3 }
- /* ternaires */
- | TK_IF sxExpression TK_THEN sxExpression TK_ELSE sxExpression
- { ternexp_predef $1 IF_n $2 $4 $6 }
- | TK_WITH sxExpression TK_THEN sxExpression TK_ELSE sxExpression
+ /* zéroaires */
+ sxConstant { $1 }
+ | sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
+ /* unaires */
+ | TK_NOT sxExpression { unexp_predef $1 NOT_n $2 }
+ | TK_MINUS sxExpression %prec TK_UMINUS
+ { unexp_predef $1 UMINUS_n $2 }
+ | TK_PRE sxExpression { unexp $1 PRE_n $2 }
+ | TK_CURRENT sxExpression { unexp $1 CURRENT_n $2 }
+ | TK_INT sxExpression { unexp_predef $1 REAL2INT_n $2 }
+ | TK_REAL sxExpression { unexp_predef $1 INT2REAL_n $2 }
+ /* binaires */
+ | sxExpression TK_FBY sxExpression { binexp $2 FBY_n $1 $3 }
+ | sxExpression TK_ARROW sxExpression { binexp $2 ARROW_n $1 $3 }
+ | sxExpression TK_WHEN sxExpression { binexp $2 WHEN_n $1 $3 }
+ | sxExpression TK_AND sxExpression { binexp_predef $2 AND_n $1 $3 }
+ | sxExpression TK_OR sxExpression { binexp_predef $2 OR_n $1 $3 }
+ | sxExpression TK_XOR sxExpression { binexp_predef $2 XOR_n $1 $3 }
+ | sxExpression TK_IMPL sxExpression { binexp_predef $2 IMPL_n $1 $3 }
+ | sxExpression TK_EQ sxExpression { binexp_predef $2 EQ_n $1 $3 }
+ | sxExpression TK_NEQ sxExpression { binexp_predef $2 NEQ_n $1 $3 }
+ | sxExpression TK_LT sxExpression { binexp_predef $2 LT_n $1 $3 }
+ | sxExpression TK_LTE sxExpression { binexp_predef $2 LTE_n $1 $3 }
+ | sxExpression TK_GT sxExpression { binexp_predef $2 GT_n $1 $3 }
+ | sxExpression TK_GTE sxExpression { binexp_predef $2 GTE_n $1 $3 }
+ | sxExpression TK_DIV sxExpression { binexp_predef $2 DIV_n $1 $3 }
+ | sxExpression TK_MOD sxExpression { binexp_predef $2 MOD_n $1 $3 }
+ | sxExpression TK_MINUS sxExpression { binexp_predef $2 MINUS_n $1 $3 }
+ | sxExpression TK_PLUS sxExpression { binexp_predef $2 PLUS_n $1 $3 }
+ | sxExpression TK_SLASH sxExpression { binexp_predef $2 SLASH_n $1 $3 }
+ | sxExpression TK_STAR sxExpression { binexp_predef $2 TIMES_n $1 $3 }
+ /* ternaires */
+ | TK_IF sxExpression TK_THEN sxExpression TK_ELSE sxExpression
+ { ternexp_predef $1 IF_n $2 $4 $6 }
+ | TK_WITH sxExpression TK_THEN sxExpression TK_ELSE sxExpression
{ CallByPos( {src = $1 ; it = WITH_n($2, $4, $6) }, Oper [] ) }
- /* n-aires */
- /* WARNING ! il faut remettre la liste à l'endroit */
- | TK_DIESE TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
- { naryexp_predef $1 DIESE_n (List.rev $3) }
- | TK_NOR TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
- { naryexp_predef $1 NOR_n (List.rev $3) }
- | sxCallByPosExpression
- { $1 }
- | TK_OPEN_PAR sxExpList2 TK_CLOSE_PAR
- { naryexp $1 TUPLE_n (List.rev $2) }
- /* Opérations sur les tableaux */
- /* -> création à partir d'une liste */
- | TK_OPEN_BRACKET sxExpressionList TK_CLOSE_BRACKET
- { naryexp $1 ARRAY_n (List.rev $2) }
- /* -> création par exponentiation */
- | sxExpression TK_HAT sxExpression { binexp $2 HAT_n $1 $3 }
- /* -> concaténation */
- | sxExpression TK_BAR sxExpression { binexp $2 CONCAT_n $1 $3 }
- /* -> accès à un élément */
- | sxExpression TK_OPEN_BRACKET sxExpression TK_CLOSE_BRACKET
- { unexp $2 (ARRAY_ACCES_n $3) $1 }
- /* -> accès à une tranche */
- | sxExpression TK_OPEN_BRACKET sxSelect TK_CLOSE_BRACKET
- { unexp $3.src (ARRAY_SLICE_n $3.it) $1 }
- /* Acces aux structures */
- | sxExpression TK_DOT sxIdent
- { unexp $2 (STRUCT_ACCESS_n (Lxm.id $3)) $1 }
- /* Appels par noms */
- | sxCallByNameExpression
- { $1 }
- /* Parenthèses */
- | TK_OPEN_PAR sxExpression TK_CLOSE_PAR
- { $2 }
- ;
+ /* n-aires */
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ | TK_DIESE TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
+ { naryexp_predef $1 DIESE_n (List.rev $3) }
+ | TK_NOR TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
+ { naryexp_predef $1 NOR_n (List.rev $3) }
+ | sxCallByPosExpression
+ { $1 }
+ | TK_OPEN_PAR sxExpList2 TK_CLOSE_PAR
+ { naryexp $1 TUPLE_n (List.rev $2) }
+ /* Opérations sur les tableaux */
+ /* -> création à partir d'une liste */
+ | TK_OPEN_BRACKET sxExpressionList TK_CLOSE_BRACKET
+ { naryexp $1 ARRAY_n (List.rev $2) }
+ /* -> création par exponentiation */
+ | sxExpression TK_HAT sxExpression { binexp $2 HAT_n $1 $3 }
+ /* -> concaténation */
+ | sxExpression TK_BAR sxExpression { binexp $2 CONCAT_n $1 $3 }
+ /* -> accès à un élément */
+ | sxExpression TK_OPEN_BRACKET sxExpression TK_CLOSE_BRACKET
+ { unexp $2 (ARRAY_ACCES_n $3) $1 }
+ /* -> accès à une tranche */
+ | sxExpression TK_OPEN_BRACKET sxSelect TK_CLOSE_BRACKET
+ { unexp $3.src (ARRAY_SLICE_n $3.it) $1 }
+ /* Acces aux structures */
+ | sxExpression TK_DOT sxIdent
+ { unexp $2 (STRUCT_ACCESS_n (Lxm.id $3)) $1 }
+ /* Appels par noms */
+ | sxCallByNameExpression
+ { $1 }
+ /* Parenthèses */
+ | TK_OPEN_PAR sxExpression TK_CLOSE_PAR
+ { $2 }
+ ;
sxPredefOp:
- | TK_NOT { {src=$1; it=Predef(NOT_n,[])} }
- | TK_FBY { {src=$1; it=FBY_n} }
- | TK_PRE { {src=$1; it=PRE_n} }
- | TK_CURRENT{ {src=$1; it=CURRENT_n} }
- | TK_ARROW { {src=$1; it=ARROW_n} }
- | TK_WHEN { {src=$1; it=WHEN_n} }
- | TK_AND { {src=$1; it=Predef(AND_n,[]) } }
- | TK_OR { {src=$1; it=Predef(OR_n,[]) } }
- | TK_XOR { {src=$1; it=Predef(XOR_n,[]) } }
- | TK_IMPL { {src=$1; it=Predef(IMPL_n,[]) } }
- | TK_EQ { {src=$1; it=Predef(EQ_n,[]) } }
- | TK_NEQ { {src=$1; it=Predef(NEQ_n,[]) } }
- | TK_LT { {src=$1; it=Predef(LT_n,[]) } }
- | TK_LTE { {src=$1; it=Predef(LTE_n,[]) } }
- | TK_GT { {src=$1; it=Predef(GT_n,[]) } }
- | TK_GTE { {src=$1; it=Predef(GTE_n,[]) } }
- | TK_DIV { {src=$1; it=Predef(DIV_n,[]) } }
- | TK_MOD { {src=$1; it=Predef(MOD_n,[]) } }
- | TK_MINUS { {src=$1; it=Predef(MINUS_n,[]) } }
- | TK_PLUS { {src=$1; it=Predef(PLUS_n,[]) } }
- | TK_SLASH { {src=$1; it=Predef(SLASH_n,[]) } }
- | TK_STAR { {src=$1; it=Predef(TIMES_n,[]) } }
- | TK_IF { {src=$1; it=Predef(IF_n,[]) } }
+ | TK_NOT { {src=$1; it=Predef(NOT_n,[])} }
+ | TK_FBY { {src=$1; it=FBY_n} }
+ | TK_PRE { {src=$1; it=PRE_n} }
+ | TK_CURRENT{ {src=$1; it=CURRENT_n} }
+ | TK_ARROW { {src=$1; it=ARROW_n} }
+ | TK_WHEN { {src=$1; it=WHEN_n} }
+ | TK_AND { {src=$1; it=Predef(AND_n,[]) } }
+ | TK_OR { {src=$1; it=Predef(OR_n,[]) } }
+ | TK_XOR { {src=$1; it=Predef(XOR_n,[]) } }
+ | TK_IMPL { {src=$1; it=Predef(IMPL_n,[]) } }
+ | TK_EQ { {src=$1; it=Predef(EQ_n,[]) } }
+ | TK_NEQ { {src=$1; it=Predef(NEQ_n,[]) } }
+ | TK_LT { {src=$1; it=Predef(LT_n,[]) } }
+ | TK_LTE { {src=$1; it=Predef(LTE_n,[]) } }
+ | TK_GT { {src=$1; it=Predef(GT_n,[]) } }
+ | TK_GTE { {src=$1; it=Predef(GTE_n,[]) } }
+ | TK_DIV { {src=$1; it=Predef(DIV_n,[]) } }
+ | TK_MOD { {src=$1; it=Predef(MOD_n,[]) } }
+ | TK_MINUS { {src=$1; it=Predef(MINUS_n,[]) } }
+ | TK_PLUS { {src=$1; it=Predef(PLUS_n,[]) } }
+ | TK_SLASH { {src=$1; it=Predef(SLASH_n,[]) } }
+ | TK_STAR { {src=$1; it=Predef(TIMES_n,[]) } }
+ | TK_IF { {src=$1; it=Predef(IF_n,[]) } }
;
/* Appel fonctionnel par position (classique) */
/* NB
- On a 2 règles à cause des appels échantillonné
+ On a 2 règles à cause des appels échantillonné
*/
sxCallByPosExpression:
- sxEffectiveNode TK_OPEN_PAR sxExpression TK_CLOSE_PAR
- { naryexp $1.src (CALL_n $1) [$3] }
- /* WARNING ! il faut remettre la liste à l'endroit */
- | sxEffectiveNode TK_OPEN_PAR sxExpList2 TK_CLOSE_PAR
- { naryexp $1.src (CALL_n $1) (List.rev $3) }
- ;
+ sxEffectiveNode TK_OPEN_PAR sxExpression TK_CLOSE_PAR
+ { naryexp $1.src (CALL_n $1) [$3] }
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ | sxEffectiveNode TK_OPEN_PAR sxExpList2 TK_CLOSE_PAR
+ { naryexp $1.src (CALL_n $1) (List.rev $3) }
+ ;
/* Effective node : une constrcution qui designe un noeud */
sxEffectiveNode:
- /* Juste un nom */
- sxIdentRef
- { {src=$1.src; it=(($1.it, [])) } }
- /* Un nom + des params statiques */
- | sxIdentRef TK_OPEN_STATIC_PAR sxStaticArgList TK_CLOSE_STATIC_PAR
- { {src=$1.src; it=(($1.it, List.rev $3)) } }
- /* Un operateur prédéfini
- | TK_OPERATOR sxPredefOp,[]
- { {src=$; it=($2.it, []) } }
- ;
+ /* Juste un nom */
+ sxIdentRef
+ { {src=$1.src; it=(($1.it, [])) } }
+ /* Un nom + des params statiques */
+ | sxIdentRef TK_OPEN_STATIC_PAR sxStaticArgList TK_CLOSE_STATIC_PAR
+ { {src=$1.src; it=(($1.it, List.rev $3)) } }
+ /* Un operateur prédéfini
+ | TK_OPERATOR sxPredefOp,[]
+ { {src=$; it=($2.it, []) } }
+ ;
XXX pour l'instant, j'enleve la possibilité d'avoir
(operator +(1,2)). On verra ca plus tard
*/
sxStaticArgList:
- sxStaticArg
- { [$1] }
- | sxStaticArgList TK_COMA sxStaticArg
- { $3::$1 }
- /* let's be permissive... */
- | sxStaticArgList TK_SEMICOL sxStaticArg
- { $3::$1 }
- ;
+ sxStaticArg
+ { [$1] }
+ | sxStaticArgList TK_COMA sxStaticArg
+ { $3::$1 }
+ /* let's be permissive... */
+ | sxStaticArgList TK_SEMICOL sxStaticArg
+ { $3::$1 }
+ ;
/* Faut se tordre l'esprit ici !
- la nature est explicite,
- - la nature est immediate (type, const ou node predefini)
- - la nature est sans ambiguite const (expressions simples)
- - la nature est compile-time (juste un ident, a résoudre)
- */
+ - la nature est immediate (type, const ou node predefini)
+ - la nature est sans ambiguite const (expressions simples)
+ - la nature est compile-time (juste un ident, a résoudre)
+ */
sxStaticArg:
- /* nature explicite */
- | TK_TYPE sxType
- { {src=$1 ; it=StaticArgType $2 } }
- | TK_CONST sxExpression
- { {src=$1 ; it=StaticArgConst $2 } }
- | TK_NODE sxEffectiveNode
- { {src=$1 ; it=StaticArgNode (CALL_n $2) } }
- | TK_FUNCTION sxEffectiveNode
- { {src=$1 ; it=StaticArgNode (CALL_n $2) } }
- | sxPredefOp
- { {src=$1.src; it=StaticArgNode $1.it } }
- /* un ident OU une expression simple (à résoudre) */
- /* c'est au retour qu'on choisit */
- | sxSimpleExp
- {
- match $1 with
- | CallByPos (op, x) -> (
- match op.it with
- | IDENT_n idref -> {src=op.src ; it = StaticArgIdent idref }
- | _ -> {src=op.src ; it= StaticArgConst $1}
- )
- | CallByName _ ->
- print_string "*** unexpected static argument\n";
- assert false
- }
- /* un type sans ambiguite */
- | sxSurelyType
- { {src=$1.src; it=StaticArgType $1} }
- /* un node sans ambiguite */
- | sxSurelyNode
- { {src=$1.src; it=StaticArgNode (CALL_n $1)} }
+ /* nature explicite */
+ | TK_TYPE sxType
+ { {src=$1 ; it=StaticArgType $2 } }
+ | TK_CONST sxExpression
+ { {src=$1 ; it=StaticArgConst $2 } }
+ | TK_NODE sxEffectiveNode
+ { {src=$1 ; it=StaticArgNode (CALL_n $2) } }
+ | TK_FUNCTION sxEffectiveNode
+ { {src=$1 ; it=StaticArgNode (CALL_n $2) } }
+ | sxPredefOp
+ { {src=$1.src; it=StaticArgNode $1.it } }
+ /* un ident OU une expression simple (à résoudre) */
+ /* c'est au retour qu'on choisit */
+ | sxSimpleExp
+ {
+ match $1 with
+ | CallByPos (op, x) -> (
+ match op.it with
+ | IDENT_n idref -> {src=op.src ; it = StaticArgIdent idref }
+ | _ -> {src=op.src ; it= StaticArgConst $1}
+ )
+ | CallByName _ ->
+ print_string "*** unexpected static argument\n";
+ assert false
+ }
+ /* un type sans ambiguite */
+ | sxSurelyType
+ { {src=$1.src; it=StaticArgType $1} }
+ /* un node sans ambiguite */
+ | sxSurelyNode
+ { {src=$1.src; it=StaticArgNode (CALL_n $1)} }
;
sxSurelyNode:
- | sxIdentRef TK_OPEN_STATIC_PAR sxStaticArgList TK_CLOSE_STATIC_PAR
- { {src=$1.src; it=($1.it, List.rev $3) } }
+ | sxIdentRef TK_OPEN_STATIC_PAR sxStaticArgList TK_CLOSE_STATIC_PAR
+ { {src=$1.src; it=($1.it, List.rev $3) } }
;
sxSurelyType:
- /* prédéfini */
- TK_BOOL { {src=$1; it=Bool_type_exp} }
- | TK_INT { {src=$1; it=Int_type_exp} }
- | TK_REAL { {src=$1; it=Real_type_exp} }
- /* ou tableau immédiat */
- | sxSurelyType TK_HAT sxExpression
- { {src=$1.src; it = Array_type_exp ($1 , $3) } }
- ;
+ /* prédéfini */
+ TK_BOOL { {src=$1; it=Bool_type_exp} }
+ | TK_INT { {src=$1; it=Int_type_exp} }
+ | TK_REAL { {src=$1; it=Real_type_exp} }
+ /* ou tableau immédiat */
+ | sxSurelyType TK_HAT sxExpression
+ { {src=$1.src; it = Array_type_exp ($1 , $3) } }
+ ;
/* sxSimpleExp = statically evaluable exp */
sxSimpleExp:
- sxConstant { $1 }
- | sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
- | TK_OPEN_PAR sxSimpleExp TK_CLOSE_PAR { $2 }
- | TK_NOT sxSimpleExp { unexp_predef $1 NOT_n $2 }
- | TK_MINUS sxSimpleExp %prec TK_UMINUS { unexp_predef $1 UMINUS_n $2 }
- | sxSimpleExp TK_AND sxSimpleExp { binexp_predef $2 AND_n $1 $3 }
- | sxSimpleExp TK_OR sxSimpleExp { binexp_predef $2 OR_n $1 $3 }
- | sxSimpleExp TK_XOR sxSimpleExp { binexp_predef $2 XOR_n $1 $3 }
- | sxSimpleExp TK_IMPL sxSimpleExp { binexp_predef $2 IMPL_n $1 $3 }
- | sxSimpleExp TK_EQ sxSimpleExp { binexp_predef $2 EQ_n $1 $3 }
- | sxSimpleExp TK_NEQ sxSimpleExp { binexp_predef $2 NEQ_n $1 $3 }
- | sxSimpleExp TK_LT sxSimpleExp { binexp_predef $2 LT_n $1 $3 }
- | sxSimpleExp TK_LTE sxSimpleExp { binexp_predef $2 LTE_n $1 $3 }
- | sxSimpleExp TK_GT sxSimpleExp { binexp_predef $2 GT_n $1 $3 }
- | sxSimpleExp TK_GTE sxSimpleExp { binexp_predef $2 GTE_n $1 $3 }
- | sxSimpleExp TK_DIV sxSimpleExp { binexp_predef $2 DIV_n $1 $3 }
- | sxSimpleExp TK_MOD sxSimpleExp { binexp_predef $2 MOD_n $1 $3 }
- | sxSimpleExp TK_MINUS sxSimpleExp { binexp_predef $2 MINUS_n $1 $3 }
- | sxSimpleExp TK_PLUS sxSimpleExp { binexp_predef $2 PLUS_n $1 $3 }
- | sxSimpleExp TK_SLASH sxSimpleExp { binexp_predef $2 SLASH_n $1 $3 }
- | sxSimpleExp TK_STAR sxSimpleExp { binexp_predef $2 TIMES_n $1 $3 }
- /* ternaires */
- | TK_IF sxSimpleExp TK_THEN sxSimpleExp TK_ELSE sxSimpleExp
- { ternexp_predef $1 IF_n $2 $4 $6 }
- ;
+ sxConstant { $1 }
+ | sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
+ | TK_OPEN_PAR sxSimpleExp TK_CLOSE_PAR { $2 }
+ | TK_NOT sxSimpleExp { unexp_predef $1 NOT_n $2 }
+ | TK_MINUS sxSimpleExp %prec TK_UMINUS { unexp_predef $1 UMINUS_n $2 }
+ | sxSimpleExp TK_AND sxSimpleExp { binexp_predef $2 AND_n $1 $3 }
+ | sxSimpleExp TK_OR sxSimpleExp { binexp_predef $2 OR_n $1 $3 }
+ | sxSimpleExp TK_XOR sxSimpleExp { binexp_predef $2 XOR_n $1 $3 }
+ | sxSimpleExp TK_IMPL sxSimpleExp { binexp_predef $2 IMPL_n $1 $3 }
+ | sxSimpleExp TK_EQ sxSimpleExp { binexp_predef $2 EQ_n $1 $3 }
+ | sxSimpleExp TK_NEQ sxSimpleExp { binexp_predef $2 NEQ_n $1 $3 }
+ | sxSimpleExp TK_LT sxSimpleExp { binexp_predef $2 LT_n $1 $3 }
+ | sxSimpleExp TK_LTE sxSimpleExp { binexp_predef $2 LTE_n $1 $3 }
+ | sxSimpleExp TK_GT sxSimpleExp { binexp_predef $2 GT_n $1 $3 }
+ | sxSimpleExp TK_GTE sxSimpleExp { binexp_predef $2 GTE_n $1 $3 }
+ | sxSimpleExp TK_DIV sxSimpleExp { binexp_predef $2 DIV_n $1 $3 }
+ | sxSimpleExp TK_MOD sxSimpleExp { binexp_predef $2 MOD_n $1 $3 }
+ | sxSimpleExp TK_MINUS sxSimpleExp { binexp_predef $2 MINUS_n $1 $3 }
+ | sxSimpleExp TK_PLUS sxSimpleExp { binexp_predef $2 PLUS_n $1 $3 }
+ | sxSimpleExp TK_SLASH sxSimpleExp { binexp_predef $2 SLASH_n $1 $3 }
+ | sxSimpleExp TK_STAR sxSimpleExp { binexp_predef $2 TIMES_n $1 $3 }
+ /* ternaires */
+ | TK_IF sxSimpleExp TK_THEN sxSimpleExp TK_ELSE sxSimpleExp
+ { ternexp_predef $1 IF_n $2 $4 $6 }
+ ;
/* Appel fonctionnel par nom */
/* NB
@@ -965,73 +965,73 @@ Actuellement, uniquement pour les structures,
donc pas de soucis d'échantillonnage
*/
sxCallByNameExpression:
- /* WARNING ! il faut remettre la liste à l'endroit */
- sxIdentRef TK_OPEN_BRACE sxCallByNameParamList sxOptSemicol TK_CLOSE_BRACE
- { bynameexp $1.src (STRUCT_n $1.it) (List.rev $3) }
- /* on peut avoir une liste vide */
- | sxIdentRef TK_OPEN_BRACE TK_CLOSE_BRACE
- { bynameexp $1.src (STRUCT_n $1.it) ([]) }
- /* COMPATIBILITY : immediate "struct" without the type name
- | TK_OPEN_BRACE sxCallByNameParamList sxOptSemicol TK_CLOSE_BRACE
- { bynameexp $1 STRUCT_anonymous_n (List.rev $2) } */
- ;
+ /* WARNING ! il faut remettre la liste à l'endroit */
+ sxIdentRef TK_OPEN_BRACE sxCallByNameParamList sxOptSemicol TK_CLOSE_BRACE
+ { bynameexp $1.src (STRUCT_n $1.it) (List.rev $3) }
+ /* on peut avoir une liste vide */
+ | sxIdentRef TK_OPEN_BRACE TK_CLOSE_BRACE
+ { bynameexp $1.src (STRUCT_n $1.it) ([]) }
+ /* COMPATIBILITY : immediate "struct" without the type name
+ | TK_OPEN_BRACE sxCallByNameParamList sxOptSemicol TK_CLOSE_BRACE
+ { bynameexp $1 STRUCT_anonymous_n (List.rev $2) } */
+ ;
sxCallByNameParamList:
- sxCallByNameParam
- { [$1] }
- |
- sxCallByNameParamList sepVariant sxCallByNameParam
- { $3::$1 }
- ;
+ sxCallByNameParam
+ { [$1] }
+ |
+ sxCallByNameParamList sepVariant sxCallByNameParam
+ { $3::$1 }
+ ;
/* COMPATIBILITY : ',' or ';' */
sepVariant:
- TK_SEMICOL
- {}
-| TK_COMA
- { Errors.warning $1 "separator mismatch, ';' expected"}
+ TK_SEMICOL
+ {}
+| TK_COMA
+ { Errors.warning $1 "separator mismatch, ';' expected"}
;
-
+
sxCallByNameParam:
- sxIdent TK_EQ sxExpression
- { ({it=Lxm.id $1;src=$1} , $3) }
- ;
+ sxIdent TK_EQ sxExpression
+ { ({it=Lxm.id $1;src=$1} , $3) }
+ ;
/* WARNING ! : les listes sont crées à l'envers */
sxExpressionList: sxExpression
- { [$1] }
- | sxExpList2
- { $1 }
- ;
+ { [$1] }
+ | sxExpList2
+ { $1 }
+ ;
sxConstant: TK_TRUE
- { (leafexp $1 (Predef(TRUE_n,[]))) }
- | TK_FALSE
- { (leafexp $1 (Predef(FALSE_n,[]))) }
- | TK_ICONST
- { (leafexp $1 (Predef((ICONST_n (Lxm.id $1)),[]))) }
- | TK_RCONST
- { (leafexp $1 (Predef((RCONST_n (Lxm.id $1)),[]))) }
- ;
+ { (leafexp $1 (Predef(TRUE_n,[]))) }
+ | TK_FALSE
+ { (leafexp $1 (Predef(FALSE_n,[]))) }
+ | TK_ICONST
+ { (leafexp $1 (Predef((ICONST_n (Lxm.id $1)),[]))) }
+ | TK_RCONST
+ { (leafexp $1 (Predef((RCONST_n (Lxm.id $1)),[]))) }
+ ;
/* WARNING ! : les listes sont crées à l'envers */
sxExpList2: sxExpressionList TK_COMA sxExpression
- { $3::$1 }
- ;
+ { $3::$1 }
+ ;
sxSelect:
- sxExpression TK_CDOTS sxExpression sxStep
- { {it={si_first = $1; si_last = $3 ; si_step = $4 }; src = $2} }
-| TK_SLICE_START sxExpression sxStep
- { threat_slice_start $1 $2 $3 }
- ;
+ sxExpression TK_CDOTS sxExpression sxStep
+ { {it={si_first = $1; si_last = $3 ; si_step = $4 }; src = $2} }
+| TK_SLICE_START sxExpression sxStep
+ { threat_slice_start $1 $2 $3 }
+ ;
sxStep: /* empty */
- { None }
- | TK_STEP sxExpression
- { Some $2 }
- ;
+ { None }
+ | TK_STEP sxExpression
+ { Some $2 }
+ ;
/* NB
SyntaxTree laxiste des listes :
quand il n'y a pas d'ambiguité,
@@ -1039,14 +1039,14 @@ les ";" sont vus indifferemment commme
des séparateurs ou des terminateurs
*/
sxOptSemicol :
- /* empty */
- {}
- | TK_SEMICOL
- {}
- ;
+ /* empty */
+ {}
+ | TK_SEMICOL
+ {}
+ ;
sxPragma: /* e.g., %ASSUME:toto% */
- { [] } /* produces 3 shift reduce conflicts! */
-| TK_PCENT TK_IDENT TK_COLON TK_IDENT TK_PCENT sxPragma
- { (Pragma(Lxm.str $2, Lxm.str $4))::$6 }
-
+ { [] } /* produces 3 shift reduce conflicts! */
+| TK_PCENT TK_IDENT TK_COLON TK_IDENT TK_PCENT sxPragma
+ { (Pragma(Lxm.str $2, Lxm.str $4))::$6 }
+
diff --git a/src/parserUtils.ml b/src/parserUtils.ml
index 8e230a56..3c1600e5 100644
--- a/src/parserUtils.ml
+++ b/src/parserUtils.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 10/06/2008 (at 10:20) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:29) by Erwan Jahier> *)
@@ -14,23 +14,23 @@ let (build_node_var : var_info srcflagged list -> var_info srcflagged list ->
fun invars outvars locvars_opt ->
let get_var_name vif = vif.it.var_name in
{
- inlist = List.map get_var_name invars;
- outlist = List.map get_var_name outvars;
- loclist = (
- match locvars_opt with
- | None -> None
- | Some locvars -> Some (List.map get_var_name locvars)
- );
- vartable =
- let tbl = Hashtbl.create 0 in
- let add_var_in_tbl vif = Hashtbl.add tbl vif.it.var_name vif in
- List.iter add_var_in_tbl invars;
- List.iter add_var_in_tbl outvars;
- (match locvars_opt with
- | None -> ()
- | Some locvars -> List.iter add_var_in_tbl locvars
- );
- tbl;
+ inlist = List.map get_var_name invars;
+ outlist = List.map get_var_name outvars;
+ loclist = (
+ match locvars_opt with
+ | None -> None
+ | Some locvars -> Some (List.map get_var_name locvars)
+ );
+ vartable =
+ let tbl = Hashtbl.create 0 in
+ let add_var_in_tbl vif = Hashtbl.add tbl vif.it.var_name vif in
+ List.iter add_var_in_tbl invars;
+ List.iter add_var_in_tbl outvars;
+ (match locvars_opt with
+ | None -> ()
+ | Some locvars -> List.iter add_var_in_tbl locvars
+ );
+ tbl;
}
(* Une collection de "meta fonctions" pour faciliter la vie *)
@@ -70,12 +70,12 @@ let flat_flagged_list
= (
(*g: concatene les 'c list*)
let g (cl: 'c list) ((al: 'a list) , (b: 'b)) = (
- (*f: fabrique un 'c *)
- let f (a: 'a) = makeitem a b in
- List.append cl (List.map f al)
+ (*f: fabrique un 'c *)
+ let f (a: 'a) = makeitem a b in
+ List.append cl (List.map f al)
) in
- (*on folde g sur inlist*)
- List.fold_left g [] inlist
+ (*on folde g sur inlist*)
+ List.fold_left g [] inlist
)
let _ = assert (
@@ -107,13 +107,13 @@ let flat_twice_flagged_list
(makeitem: 'a -> 'b -> 'c -> 'd )
= (
let g (dl: 'd list) ((albl: ('a list * 'b) list), (c: 'c)) = (
- let h (dl: 'd list) ((al: 'a list), (b: 'b)) = (
- let f (a: 'a) = makeitem a b c in
- List.append dl (List.map f al)
- ) in
- List.fold_left h dl albl
+ let h (dl: 'd list) ((al: 'a list), (b: 'b)) = (
+ let f (a: 'a) = makeitem a b c in
+ List.append dl (List.map f al)
+ ) in
+ List.fold_left h dl albl
) in
- List.fold_left g [] inlist
+ List.fold_left g [] inlist
)
(**********************************************************************************)
@@ -122,20 +122,20 @@ let flat_twice_flagged_list
let leafexp lxm op = CallByPos({src = lxm ; it = op }, Oper [])
-let unexp lxm op e1 = CallByPos( {src = lxm ; it = op }, Oper [e1] )
+let unexp lxm op e1 = CallByPos( {src = lxm ; it = op }, Oper [e1] )
let unexp_predef lxm op e1 = CallByPos( {src = lxm ; it = Predef (op,[]) }, Oper [e1] )
let binexp lxm op e1 e2 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2] )
let binexp_predef lxm op e1 e2 = CallByPos( {src = lxm ; it = Predef (op,[]) },
- Oper [e1 ; e2] )
+ Oper [e1 ; e2] )
let ternexp lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2; e3] )
let ternexp_predef lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = Predef (op,[]) },
- Oper [e1 ; e2; e3] )
+ Oper [e1 ; e2; e3] )
-let naryexp lxm op elst = CallByPos( {src = lxm ; it = op }, Oper elst )
+let naryexp lxm op elst = CallByPos( {src = lxm ; it = op }, Oper elst )
let naryexp_predef lxm op elst = CallByPos( {src = lxm ; it = Predef (op,[]) },
- Oper elst )
+ Oper elst )
let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )
@@ -156,11 +156,11 @@ let idref_of_lxm lxm =
(** add_info
-----------------------------------------------------------------------
Rôle :
- proc générique pour mettre une info 'a dans
- une table (Ident.t, 'a srcflagged).
+ proc générique pour mettre une info 'a dans
+ une table (Ident.t, 'a srcflagged).
Effets de bord :
- erreur de compil si déjà utilisé
+ erreur de compil si déjà utilisé
*)
let (add_info : (Ident.t, 'a srcflagged) Hashtbl.t ->
string -> (* une string en cas d'erreur *)
@@ -170,16 +170,16 @@ let (add_info : (Ident.t, 'a srcflagged) Hashtbl.t ->
fun htbl kindof lxm info ->
try
let x = Hashtbl.find htbl (Lxm.id lxm) in
- raise (
- Errors.Compile_error (
- lxm,
- Printf.sprintf "bad %s declaration, ident already linked at %s" kindof
- (Lxm.position x.src)
- )
- )
+ raise (
+ Errors.Compile_error (
+ lxm,
+ Printf.sprintf "bad %s declaration, ident already linked at %s" kindof
+ (Lxm.position x.src)
+ )
+ )
with Not_found ->
Hashtbl.add htbl (Lxm.id lxm) { src = lxm ; it = info }
-
+
(**********************************************************************************)
(* local tables used to store (via [add_info], see above) intermediary results
@@ -266,12 +266,12 @@ let (make_struct_type_info : Lxm.t -> id_valopt list (* la liste des champs *)
let (put_in_ftab : (Lxm.t * type_exp * val_exp option) -> Ident.t) =
(* Traitement d'un champ élémentaire *)
fun (lx, ty, va) ->
- (* fabrique le field_info *)
- let lxstr = Lxm.id lx in
- let fi = { fd_name = lxstr ; fd_type = ty ; fd_value = va } in
- (* le range dans ftab *)
- add_info ftab "field" lx fi;
- lxstr (* renvoie juste le nom du champs *)
+ (* fabrique le field_info *)
+ let lxstr = Lxm.id lx in
+ let fi = { fd_name = lxstr ; fd_type = ty ; fd_value = va } in
+ (* le range dans ftab *)
+ add_info ftab "field" lx fi;
+ lxstr (* renvoie juste le nom du champs *)
in
let flst = List.map put_in_ftab flexlist in
{ st_name = Lxm.id typlxm ; st_flist = flst ; st_ftable = ftab }
@@ -313,18 +313,18 @@ let (clocked_ids_to_var_infos : var_nature ->
let i = ref 0 in
let makevar lxm te ce =
let res =
- Lxm.flagit
- {
- var_nature = vnat;
- var_name = (Lxm.id lxm);
- var_number = !i;
- var_type = te;
- var_clock = ce;
- }
- lxm
+ Lxm.flagit
+ {
+ var_nature = vnat;
+ var_name = (Lxm.id lxm);
+ var_number = !i;
+ var_type = te;
+ var_clock = ce;
+ }
+ lxm
in
- incr i;
- res
+ incr i;
+ res
in
flat_twice_flagged_list vdefs makevar
@@ -344,22 +344,22 @@ let (treat_node_decl : bool -> Lxm.t -> static_param srcflagged list ->
let rec (treat_vars : clocked_ids list -> var_nature -> var_info srcflagged list) =
(* Procedure de traitement des in, out ou loc, paramétrée par la [var_nature] *)
fun vdefs nat ->
- let i = ref 0 in
- match vdefs with
- | [] -> []
- | (tids, ck)::reste ->
- let put_var_in_table (lxm: Lxm.t) (ty: type_exp) =
- let vinfo = {
- var_nature = nat; var_name = (Lxm.id lxm);
- var_type = ty; var_clock = ck; var_number = !i
- }
- in
- incr i;
- add_info vtable "variable" lxm vinfo;
- Lxm.flagit vinfo lxm
- in
- (flat_flagged_list tids put_var_in_table)
- @ (treat_vars reste nat)
+ let i = ref 0 in
+ match vdefs with
+ | [] -> []
+ | (tids, ck)::reste ->
+ let put_var_in_table (lxm: Lxm.t) (ty: type_exp) =
+ let vinfo = {
+ var_nature = nat; var_name = (Lxm.id lxm);
+ var_type = ty; var_clock = ck; var_number = !i
+ }
+ in
+ incr i;
+ add_info vtable "variable" lxm vinfo;
+ Lxm.flagit vinfo lxm
+ in
+ (flat_flagged_list tids put_var_in_table)
+ @ (treat_vars reste nat)
in
let invars = treat_vars indefs VarInput
and outvars = treat_vars outdefs VarOutput
@@ -388,8 +388,8 @@ let (treat_node_alias : bool -> Lxm.t -> static_param srcflagged list ->
let nstr = Lxm.id nlxm in
let vars =
match node_profile with
- | None -> None
- | Some (invars,outvars) -> Some (build_node_var invars outvars None)
+ | None -> None
+ | Some (invars,outvars) -> Some (build_node_var invars outvars None)
in
let ninfo = {
name = nstr;
@@ -445,7 +445,7 @@ let (treat_external_node : bool -> Lxm.t ->
fun has_memory ext_nodelxm inpars outpars ->
let ninfo =
treat_abstract_or_extern_node_do (* external nodes look like abstract nodes indeed *)
- has_memory ext_nodelxm inpars outpars false
+ has_memory ext_nodelxm inpars outpars false
in
let statics = [] in (* no static args for external node (for now at least) *)
add_info node_table "(extern) node" ext_nodelxm ninfo ;
@@ -457,24 +457,24 @@ let (threat_slice_start : Lxm.t -> val_exp -> val_exp option -> slice_info srcfl
let str = Lxm.str lxm in
let int_to_val_exp istr =
try
- ignore (int_of_string istr);
- CallByPos(flagit (Predef(ICONST_n (Ident.of_string(istr)),[])) lxm,
- Oper [])
+ ignore (int_of_string istr);
+ CallByPos(flagit (Predef(ICONST_n (Ident.of_string(istr)),[])) lxm,
+ Oper [])
with _ ->
- CallByPos(flagit (IDENT_n (Ident.idref_of_string(istr))) lxm,
- Oper [])
+ CallByPos(flagit (IDENT_n (Ident.idref_of_string(istr))) lxm,
+ Oper [])
in
match Str.split (Str.regexp (Str.quote "..")) str with
- | [first] ->
- let slice_info =
- {
- si_first = int_to_val_exp first;
- si_last = last;
- si_step = step
- }
- in
- flagit slice_info lxm
- | _ -> assert false
+ | [first] ->
+ let slice_info =
+ {
+ si_first = int_to_val_exp first;
+ si_last = last;
+ si_step = step
+ }
+ in
+ flagit slice_info lxm
+ | _ -> assert false
diff --git a/src/predef.ml b/src/predef.ml
index 8561f41c..31883eb5 100644
--- a/src/predef.ml
+++ b/src/predef.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 25/08/2008 (at 17:13) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:29) by Erwan Jahier> *)
(* XXX shoud not type int, real, and bool be handled there ? *)
@@ -145,11 +145,11 @@ let (string_to_op : string -> op) =
(* zero-ary *)
| "true" -> TRUE_n
| "false" -> FALSE_n
- (* unary *)
+ (* unary *)
| "not" -> NOT_n
| "real2int" -> REAL2INT_n
| "int2real" -> INT2REAL_n
- (* binary *)
+ (* binary *)
| "and" -> AND_n
| "or" -> OR_n
| "xor" -> XOR_n
@@ -162,9 +162,9 @@ let (string_to_op : string -> op) =
| "gte" -> GTE_n
| "div" -> DIV_n
| "mod" -> MOD_n
- (* ternary *)
+ (* ternary *)
| "if" -> IF_n
- (* n-ary *)
+ (* n-ary *)
| "nor" -> NOR_n
| "#" -> DIESE_n
| "diese" -> DIESE_n
diff --git a/src/predefEvalClock.ml b/src/predefEvalClock.ml
index d7db24c6..14921087 100644
--- a/src/predefEvalClock.ml
+++ b/src/predefEvalClock.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 30/06/2008 (at 10:14) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:29) by Erwan Jahier> *)
open Predef
open CompiledData
@@ -58,12 +58,12 @@ let (f: op -> Lxm.t -> CompiledData.static_arg_eff list -> clocker) =
| RMINUS_n | RPLUS_n | RTIMES_n | RSLASH_n
| DIV_n | MOD_n | IMINUS_n | IPLUS_n | ISLASH_n | ITIMES_n
| NOR_n | DIESE_n
- -> op_profile
+ -> op_profile
| IF_n -> if_clock_profile lxm sargs
| Red | Fill | FillRed -> fillred_clock_profile lxm sargs
| Map -> map_clock_profile lxm sargs
| BoolRed -> boolred_clock_profile lxm sargs
-
+
diff --git a/src/predefEvalConst.ml b/src/predefEvalConst.ml
index 8ccfe312..c0b2a393 100644
--- a/src/predefEvalConst.ml
+++ b/src/predefEvalConst.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/05/2008 (at 14:57) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:29) by Erwan Jahier> *)
open Predef
open SyntaxTreeCore
@@ -14,14 +14,14 @@ exception EvalConst_error of string
let (type_error_const : const_eff list -> string -> 'a) =
fun v expect ->
raise (EvalConst_error(
- "type mismatch "^(if expect = "" then "" else (expect^" expected"))))
+ "type mismatch "^(if expect = "" then "" else (expect^" expected"))))
let (arity_error_const : const_eff list -> string -> 'a) =
fun v expect ->
raise (EvalConst_error(
- Printf.sprintf "\n*** arity error: %d argument%s, whereas %s were expected"
- (List.length v) (if List.length v>1 then "s" else "") expect))
+ Printf.sprintf "\n*** arity error: %d argument%s, whereas %s were expected"
+ (List.length v) (if List.length v>1 then "s" else "") expect))
let (bbb_evaluator:(bool -> bool -> bool) -> const_evaluator) =
@@ -34,7 +34,7 @@ let (ooo_evaluator:(int -> int -> int) -> (float -> float -> float) ->
fun opi opr -> fun ll -> match List.flatten ll with
| [Int_const_eff v0; Int_const_eff v1] -> [Int_const_eff (opi v0 v1)]
| [Real_const_eff v0; Real_const_eff v1] -> [Real_const_eff (opr v0 v1)]
- (* XXX should we evaluate reals ??? *)
+ (* XXX should we evaluate reals ??? *)
| _ -> assert false (* should not occur because eval_type is called before *)
let (iii_evaluator:(int -> int -> int) -> const_evaluator) =
@@ -51,37 +51,37 @@ let (fff_evaluator:(float -> float -> float) -> const_evaluator) =
fun op -> fun ll -> match List.flatten ll with
| [Real_const_eff v0; Real_const_eff v1] -> [Real_const_eff (op v0 v1)]
| _ -> assert false (* should not occur because eval_type is called before *)
-
+
let (bb_evaluator:(bool -> bool) -> const_evaluator) =
fun op -> fun ll -> match List.flatten ll with
| [Bool_const_eff v0] -> [Bool_const_eff (op v0)]
| _ -> assert false (* should not occur because eval_type is called before *)
-
+
let (ii_evaluator:(int -> int) -> const_evaluator) =
fun op -> fun ll -> match List.flatten ll with
| [Int_const_eff v0] -> [Int_const_eff (op v0)]
| _ -> assert false (* should not occur because eval_type is called before *)
-
+
let (ff_evaluator:(float -> float) -> const_evaluator) =
fun op -> fun ll -> match List.flatten ll with
| [Real_const_eff v0] -> [Real_const_eff (op v0)]
| _ -> assert false (* should not occur because eval_type is called before *)
-
+
let (oo_evaluator:(int -> int) -> (float -> float) -> const_evaluator) =
fun opi opr -> fun ll -> match List.flatten ll with
| [Int_const_eff v0] -> [Int_const_eff (opi v0)]
| [Real_const_eff v0] -> [Real_const_eff (opr v0)]
- (* XXX should we evaluate reals ??? *)
+ (* XXX should we evaluate reals ??? *)
| _ -> assert false (* should not occur because eval_type is called before *)
-
+
let (sf_evaluator: Ident.t -> const_evaluator) =
fun id ceff_ll ->
try let v = float_of_string (Ident.to_string id) in
[Real_const_eff v]
with Failure "float_of_string" ->
raise (EvalConst_error(
- Printf.sprintf "\n*** fail to convert the string \"%s\" into a float"
- (Ident.to_string id)))
+ Printf.sprintf "\n*** fail to convert the string \"%s\" into a float"
+ (Ident.to_string id)))
let (si_evaluator: Ident.t -> const_evaluator) =
fun id ceff_ll ->
@@ -89,8 +89,8 @@ let (si_evaluator: Ident.t -> const_evaluator) =
[Int_const_eff v]
with Failure "int_of_string" ->
raise (EvalConst_error(
- Printf.sprintf "\n*** fail to convert the string \"%s\" into an int"
- (Ident.to_string id)))
+ Printf.sprintf "\n*** fail to convert the string \"%s\" into an int"
+ (Ident.to_string id)))
let (sb_evaluator: bool -> const_evaluator) =
fun v ceff_ll ->
@@ -105,7 +105,7 @@ let (if_evaluator: (int -> float) -> const_evaluator) =
fun op -> fun ll -> match List.flatten ll with
| [Int_const_eff v0] -> [Real_const_eff (op v0)]
| _ -> assert false (* should not occur because [eval_type] is called before *)
-
+
let (ite_evaluator : const_evaluator) =
function
| [[Bool_const_eff c]; t; e] -> if c then t else e
@@ -115,13 +115,13 @@ let (boolred_evaluator : int -> const_evaluator) =
fun max ceff_ll ->
let nb = List.fold_left
(fun acc -> function
- | (Bool_const_eff b) -> if b then acc+1 else acc | _ -> assert false)
+ | (Bool_const_eff b) -> if b then acc+1 else acc | _ -> assert false)
0
(List.flatten ceff_ll)
in
[Bool_const_eff (nb <= max)]
-
+
(* exported *)
let (f: op -> Lxm.t -> static_arg_eff list -> const_evaluator) =
fun op lxm sargs ll ->
@@ -177,66 +177,66 @@ let (f: op -> Lxm.t -> static_arg_eff list -> const_evaluator) =
(*
pour evaluer l'égalité, Pascal faisait comme ca (j'ai été plus (trop ?) brutal) :
(*----------------------------
- Calcul de l'égalité
- N.B. Sur les constantes abstraites
- on est très méfiant
- N.B. Sur les types structure,
- on fait des appels récursifs
- ----------------------------*)
+ Calcul de l'égalité
+ N.B. Sur les constantes abstraites
+ on est très méfiant
+ N.B. Sur les types structure,
+ on fait des appels récursifs
+ ----------------------------*)
let rec compute_eq
- (args : const_eff list)
- = (
- let rec fields_eq f0 f1 = (
- match (f0, f1) with
- | ([], []) ->
- [Bool_const_eff true]
-
- | ((f0,h0)::t0, (f1,h1)::t1) -> (
- assert (f0 = f1);
- match (compute_eq [h0;h1]) with
- [Bool_const_eff false] -> [Bool_const_eff false]
- | [Bool_const_eff true] -> (fields_eq t0 t1)
- | _ -> assert false
- )
- | _ -> assert false
- )
- in
- match args with
- [Bool_const_eff v0; Bool_const_eff v1] -> [Bool_const_eff (v0 = v1)]
- | [Int_const_eff v0; Int_const_eff v1] -> [Bool_const_eff (v0 = v1)]
- | [Real_const_eff v0; Real_const_eff v1] -> (
- let res = (v0 = v1) in
- warning src
- (sprintf "float in static exp: %f=%f evaluated as %b" v0 v1 res);
- [Bool_const_eff res]
- )
- (*
- 2007-07 obsolete
+ (args : const_eff list)
+ = (
+ let rec fields_eq f0 f1 = (
+ match (f0, f1) with
+ | ([], []) ->
+ [Bool_const_eff true]
+
+ | ((f0,h0)::t0, (f1,h1)::t1) -> (
+ assert (f0 = f1);
+ match (compute_eq [h0;h1]) with
+ [Bool_const_eff false] -> [Bool_const_eff false]
+ | [Bool_const_eff true] -> (fields_eq t0 t1)
+ | _ -> assert false
+ )
+ | _ -> assert false
+ )
+ in
+ match args with
+ [Bool_const_eff v0; Bool_const_eff v1] -> [Bool_const_eff (v0 = v1)]
+ | [Int_const_eff v0; Int_const_eff v1] -> [Bool_const_eff (v0 = v1)]
+ | [Real_const_eff v0; Real_const_eff v1] -> (
+ let res = (v0 = v1) in
+ warning src
+ (sprintf "float in static exp: %f=%f evaluated as %b" v0 v1 res);
+ [Bool_const_eff res]
+ )
+ (*
+ 2007-07 obsolete
- | [Extern_const_eff (v0, t0); Extern_const_eff (v1, t1)] -> (
- if (t0 <> t1) then (
- type_error args "t*t for some type t"
- ) else if (v0 <> v1) then (
- uneval_error args (
- sprintf "%s=%s (external constants)"
- (string_of_fullid v0)
- (string_of_fullid v1)
- )
- ) else (
- [Bool_const_eff true]
- )
- )
- *)
- | [Enum_const_eff (v0, t0); Enum_const_eff (v1, t1)] -> (
- if (t0 = t1) then [Bool_const_eff (v0 = v1)]
- else type_error args "t*t for some type t"
- )
- | [Struct_const_eff (f0, t0); Struct_const_eff (f1, t1)] -> (
- if (t0 = t1) then (fields_eq f0 f1)
- else type_error args "t*t for some type t"
- )
- | [x;y] -> type_error args "t*t for some type t"
- | x -> arity_error args "2"
- )
+ | [Extern_const_eff (v0, t0); Extern_const_eff (v1, t1)] -> (
+ if (t0 <> t1) then (
+ type_error args "t*t for some type t"
+ ) else if (v0 <> v1) then (
+ uneval_error args (
+ sprintf "%s=%s (external constants)"
+ (string_of_fullid v0)
+ (string_of_fullid v1)
+ )
+ ) else (
+ [Bool_const_eff true]
+ )
+ )
+ *)
+ | [Enum_const_eff (v0, t0); Enum_const_eff (v1, t1)] -> (
+ if (t0 = t1) then [Bool_const_eff (v0 = v1)]
+ else type_error args "t*t for some type t"
+ )
+ | [Struct_const_eff (f0, t0); Struct_const_eff (f1, t1)] -> (
+ if (t0 = t1) then (fields_eq f0 f1)
+ else type_error args "t*t for some type t"
+ )
+ | [x;y] -> type_error args "t*t for some type t"
+ | x -> arity_error args "2"
+ )
in
*)
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index addde1da..ee1b471b 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 27/08/2008 (at 15:55) by Erwan Jahier> *)
+(** Time-stamp: <modified the 28/08/2008 (at 10:29) by Erwan Jahier> *)
open Predef
open SyntaxTreeCore
@@ -21,23 +21,23 @@ let (type_error : type_eff list -> string -> 'a) =
let str_l = List.map LicDump.string_of_type_eff tel in
let str_provided = String.concat "*" str_l in
raise (EvalType_error(
- ("\n*** type '" ^ str_provided ^ "' was provided" ^
- (if expect = "" then ""
- else (" whereas\n*** type '" ^expect^"' was expected")))))
+ ("\n*** type '" ^ str_provided ^ "' was provided" ^
+ (if expect = "" then ""
+ else (" whereas\n*** type '" ^expect^"' was expected")))))
let (type_error2 : string -> string -> string -> 'a) =
fun provided expect msg ->
raise (EvalType_error(
- ("\n*** type '" ^ provided ^ "' was provided" ^
- (if expect = "" then ""
- else (" whereas\n*** type '" ^expect^"' was expected")) ^
- (if msg = "" then "" else ("\n*** " ^ msg)))))
+ ("\n*** type '" ^ provided ^ "' was provided" ^
+ (if expect = "" then ""
+ else (" whereas\n*** type '" ^expect^"' was expected")) ^
+ (if msg = "" then "" else ("\n*** " ^ msg)))))
let (arity_error : 'a list -> string -> 'b) =
fun v expect ->
raise (EvalType_error(
- Printf.sprintf "\n*** arity error: %d argument%s, whereas %s were expected"
- (List.length v) (if List.length v>1 then "s" else "") expect))
+ Printf.sprintf "\n*** arity error: %d argument%s, whereas %s were expected"
+ (List.length v) (if List.length v>1 then "s" else "") expect))
(*********************************************************************************)
(* a few local alias to make the node profile below more readable. *)
@@ -80,8 +80,8 @@ let (type_to_array_type: var_info_eff list -> int -> (Ident.t * type_eff) list)
let (get_node_and_constant:static_arg_eff list -> node_exp_eff * int)=
fun sargs ->
match sargs with
- | [NodeStaticArgEff(_,n);ConstStaticArgEff(_,Int_const_eff c)] -> n,c
- | _ -> assert false
+ | [NodeStaticArgEff(_,n);ConstStaticArgEff(_,Int_const_eff c)] -> n,c
+ | _ -> assert false
let map_profile =
@@ -123,13 +123,13 @@ let (fillred_profile : Lxm.t -> CompiledData.static_arg_eff list ->
let (id1, t1) = List.hd lti and (id2, t2) = List.hd lto in
let res =
if t1 = t2 then (lti,lto) else
- (* if they are not equal, they migth be unifiable *)
- match UnifyType.f [t1] [t2] with
- | Equal -> (lti,lto)
- | Unif t ->
+ (* if they are not equal, they migth be unifiable *)
+ match UnifyType.f [t1] [t2] with
+ | Equal -> (lti,lto)
+ | Unif t ->
(List.map (fun (id,tid) -> id, subst_type t tid) lti,
- List.map (fun (id,tid) -> id, subst_type t tid) lto)
- | Ko(msg) -> raise (Compile_error(lxm, msg))
+ List.map (fun (id,tid) -> id, subst_type t tid) lto)
+ | Ko(msg) -> raise (Compile_error(lxm, msg))
in
if not(LicDump.poly_op_mem lxm) then (
(* print_string ("*** Tabulating " ^ lxm._str ^":"^(string_of_int lxm._line) *)
@@ -164,15 +164,15 @@ let boolred_profile =
fun lxm sargs ->
let (get_three_constants: Lxm.t -> static_arg_eff list -> int * int * int) =
fun lxm sargs ->
- match sargs with
- | [ConstStaticArgEff(_,Int_const_eff i);
- ConstStaticArgEff(_,Int_const_eff j);
- ConstStaticArgEff(_,Int_const_eff k)] -> i,j,k
- | _ -> raise (Compile_error(lxm, "\n*** type error: 3 int were expected"))
+ match sargs with
+ | [ConstStaticArgEff(_,Int_const_eff i);
+ ConstStaticArgEff(_,Int_const_eff j);
+ ConstStaticArgEff(_,Int_const_eff k)] -> i,j,k
+ | _ -> raise (Compile_error(lxm, "\n*** type error: 3 int were expected"))
in
let (_i,_j,k) = get_three_constants lxm sargs in
[id "i", (Array_type_eff(Bool_type_eff,k))], [id "o", b]
-
+
type node_profile = (Ident.t * type_eff) list * (Ident.t * type_eff) list
@@ -202,14 +202,14 @@ let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
| BoolRed -> boolred_profile lxm sargs
| NOR_n | DIESE_n -> assert false
- (* XXX The current representation of node_profile prevent us
- from being able to represent "bool list" (i.e., operator
- of variable arity). I could extend the type node_profile,
- but is it worth the complication just to be able to define
- alias nodes on "nor" and "#"? Actually, even if I extend
- this data type, I don'ty know how I could generate an
- alias node for them anyway...
- *)
+ (* XXX The current representation of node_profile prevent us
+ from being able to represent "bool list" (i.e., operator
+ of variable arity). I could extend the type node_profile,
+ but is it worth the complication just to be able to define
+ alias nodes on "nor" and "#"? Actually, even if I extend
+ this data type, I don'ty know how I could generate an
+ alias node for them anyway...
+ *)
in
res
(* exported *)
@@ -224,24 +224,24 @@ let (make_node_exp_eff :
let to_var_info_eff nature (id, te) =
let res =
{
- var_name_eff = id;
- var_nature_eff = nature;
- var_number_eff = !i;
- var_type_eff = te;
- var_clock_eff = BaseEff;
+ var_name_eff = id;
+ var_nature_eff = nature;
+ var_number_eff = !i;
+ var_type_eff = te;
+ var_clock_eff = BaseEff;
}
in
incr i;
res
in
{
- node_key_eff = id,sargs ;
- inlist_eff = List.map (to_var_info_eff VarInput) lti;
- outlist_eff = (i:=0; List.map (to_var_info_eff VarOutput) lto);
- loclist_eff = None;
- def_eff = ExternEff;
- has_mem_eff = (match has_mem with Some b -> b | None -> true);
- is_safe_eff = true;
+ node_key_eff = id,sargs ;
+ inlist_eff = List.map (to_var_info_eff VarInput) lti;
+ outlist_eff = (i:=0; List.map (to_var_info_eff VarOutput) lto);
+ loclist_eff = None;
+ def_eff = ExternEff;
+ has_mem_eff = (match has_mem with Some b -> b | None -> true);
+ is_safe_eff = true;
lxm = lxm;
}
@@ -249,52 +249,52 @@ let (make_node_exp_eff :
let (f : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
fun op lxm sargs ll ->
match op with
- | IF_n -> (
- (* VERRUE 1 *)
- (* j'arrive pas a traiter le if de facon generique (pour l'instant...)
- a cause du fait que le if peut renvoyer un tuple.
- *)
- match ll with
- | [[Bool_type_eff]; t; e] ->
- if t = e then t else
- (type_error (List.flatten [[Bool_type_eff]; t; e]) "bool*any*any")
- | x -> (arity_error x "3")
- )
- | (NOR_n | DIESE_n) ->
- (* VERRUE 2 : cf XXX above: therefore i define an ad-hoc
- check for them. *)
- let check_nary_iter acc ceff =
- match ceff with (Bool_type_eff) ->
- acc | _ -> (type_error [ceff] "bool")
- in
- List.fold_left check_nary_iter () (List.flatten ll);
- [Bool_type_eff]
- | _ ->
- (* general case *)
- let node_eff = make_node_exp_eff (Some false) op lxm sargs in
- let lti = List.map (fun v -> v.var_type_eff) node_eff.inlist_eff
- and lto = List.map (fun v -> v.var_type_eff) node_eff.outlist_eff in
- let l = List.flatten ll in
- if (List.length l <> List.length lti) then
- arity_error [l] (string_of_int (List.length lti))
- else
- match UnifyType.f lti l with
- | Equal -> lto
- | Unif Any ->
- type_error2
- (LicDump.type_eff_list_to_string l)
- (LicDump.type_eff_list_to_string lti)
- "could not instanciate polymorphic type"
- | Unif Overload ->
- type_error2
- (LicDump.type_eff_list_to_string l)
- (LicDump.type_eff_list_to_string lti)
- "could not instanciate overloaded type"
-
- | Unif t ->
- List.map (subst_type t) lto
-
- | Ko(str) ->
- type_error2 (LicDump.type_eff_list_to_string l)
- (LicDump.type_eff_list_to_string lti) str
+ | IF_n -> (
+ (* VERRUE 1 *)
+ (* j'arrive pas a traiter le if de facon generique (pour l'instant...)
+ a cause du fait que le if peut renvoyer un tuple.
+ *)
+ match ll with
+ | [[Bool_type_eff]; t; e] ->
+ if t = e then t else
+ (type_error (List.flatten [[Bool_type_eff]; t; e]) "bool*any*any")
+ | x -> (arity_error x "3")
+ )
+ | (NOR_n | DIESE_n) ->
+ (* VERRUE 2 : cf XXX above: therefore i define an ad-hoc
+ check for them. *)
+ let check_nary_iter acc ceff =
+ match ceff with (Bool_type_eff) ->
+ acc | _ -> (type_error [ceff] "bool")
+ in
+ List.fold_left check_nary_iter () (List.flatten ll);
+ [Bool_type_eff]
+ | _ ->
+ (* general case *)
+ let node_eff = make_node_exp_eff (Some false) op lxm sargs in
+ let lti = List.map (fun v -> v.var_type_eff) node_eff.inlist_eff
+ and lto = List.map (fun v -> v.var_type_eff) node_eff.outlist_eff in
+ let l = List.flatten ll in
+ if (List.length l <> List.length lti) then
+ arity_error [l] (string_of_int (List.length lti))
+ else
+ match UnifyType.f lti l with
+ | Equal -> lto
+ | Unif Any ->
+ type_error2
+ (LicDump.type_eff_list_to_string l)
+ (LicDump.type_eff_list_to_string lti)
+ "could not instanciate polymorphic type"
+ | Unif Overload ->
+ type_error2
+ (LicDump.type_eff_list_to_string l)
+ (LicDump.type_eff_list_to_string lti)
+ "could not instanciate overloaded type"
+
+ | Unif t ->
+ List.map (subst_type t) lto
+
+ | Ko(str) ->
+ type_error2 (LicDump.type_eff_list_to_string l)
+ (LicDump.type_eff_list_to_string lti) str
--
GitLab