diff --git a/src/TODO b/src/TODO
index b74749fd5653c5ff94b70e76450b1e6ac31ce4fa..87a788df33dfa86bd5995d898dd23444a6479e66 100644
--- a/src/TODO
+++ b/src/TODO
@@ -84,11 +84,16 @@ les operateurs aritmetiques, bof.
* Dans les messages d'erreurs, le numero de colonne est faux à cause
des tabulations : y'at'il quelque chose a faire ?
+* test/should_fail/semantics/bad_call03.lus
+ Moi j'accepte ca...
+
***********************************************************************************
***********************************************************************************
*** questions pour bibi
+*parser ligne 532 : ne pas re-inverser la liste des parametres
+
* Faire qque chose pour les 2 verrues dans predefSemantics
pas facile...
diff --git a/src/compiledData.ml b/src/compiledData.ml
index 5d9ce9b7cc6c5e5347222cfb9116524ce49004b5..c7f579a8a880e6124e0a702ae1c0469a4dd2edca 100644
--- a/src/compiledData.ml
+++ b/src/compiledData.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 05/06/2008 (at 17:14) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:05) by Erwan Jahier> *)
(**
@@ -117,26 +117,16 @@ type id_solver = {
- pas d'alias
- taille des tableaux résolues
----------------------------------------------------------------------*)
+
and type_eff =
| Bool_type_eff
| Int_type_eff
| Real_type_eff
- | External_type_eff of Ident.long (* XXX nom mal choisi ?? peut-etre Abstract aussi... *)
+ | External_type_eff of Ident.long
| Enum_type_eff of Ident.long * (Ident.long list)
| Array_type_eff of type_eff * int
- | Struct_type_eff of Ident.long * (Ident.t * (type_eff * const_eff option)) list
-
-
-(* [type_eff] extended with polymorphic and overloaded variables *)
-and type_eff_ext =
- | Bool_type_eff_ext
- | Int_type_eff_ext
- | Real_type_eff_ext
- | External_type_eff_ext of Ident.long
- | Enum_type_eff_ext of Ident.long * (Ident.long list)
- | Array_type_eff_ext of type_eff_ext * int
- | Struct_type_eff_ext of
- Ident.long * (Ident.t * (type_eff_ext * const_eff option)) list
+ | Struct_type_eff of
+ Ident.long * (Ident.t * (type_eff * const_eff option)) list
| Any
| Overload
(* [Overload] is like [Any], except that it can only be [int] or [real] *)
@@ -249,7 +239,7 @@ and const_eff =
and var_info_eff = {
var_name_eff : Ident.t;
var_nature_eff : var_nature;
- var_type_eff : type_eff_ext;
+ var_type_eff : type_eff;
var_clock_eff : clock_eff;
}
and clock_eff =
@@ -311,43 +301,9 @@ type 'a check_flag =
| Checked of 'a
| Incorrect
-let rec type_eff_to_type_eff_ext = function
- | Bool_type_eff -> Bool_type_eff_ext
- | Int_type_eff -> Int_type_eff_ext
- | Real_type_eff -> Real_type_eff_ext
- | External_type_eff l -> External_type_eff_ext l
- | Enum_type_eff(l,el) -> Enum_type_eff_ext(l,el)
- | Array_type_eff(teff_ext,i) ->
- Array_type_eff_ext(type_eff_to_type_eff_ext teff_ext,i)
- | Struct_type_eff(l, fl) ->
- Struct_type_eff_ext(
- l,
- List.map
- (fun (id,(teff,copt)) -> (id,(type_eff_to_type_eff_ext teff,copt)))
- fl)
-
-exception Polymorphic
-exception Overloaded
-let rec type_eff_ext_to_type_eff = function
- | Bool_type_eff_ext -> Bool_type_eff
- | Int_type_eff_ext -> Int_type_eff
- | Real_type_eff_ext -> Real_type_eff
- | External_type_eff_ext l -> External_type_eff l
- | Enum_type_eff_ext(l,el) -> Enum_type_eff(l,el)
- | Array_type_eff_ext(teff_ext,i) ->
- Array_type_eff(type_eff_ext_to_type_eff teff_ext,i)
- | Struct_type_eff_ext(l, fl) ->
- Struct_type_eff(
- l,
- List.map
- (fun (id,(teff,copt)) -> (id,(type_eff_ext_to_type_eff teff,copt)))
- fl)
- | Any -> raise Polymorphic
- | Overload -> raise Overloaded
-
let (profile_of_node_exp_eff :
- node_exp_eff -> type_eff_ext list * type_eff_ext list) =
+ node_exp_eff -> type_eff list * type_eff list) =
fun ne ->
List.map (fun vi -> vi.var_type_eff) ne.inlist_eff,
List.map (fun vi -> vi.var_type_eff) ne.outlist_eff
@@ -439,7 +395,7 @@ let (make_local_env : node_key -> local_env) =
res
(****************************************************************************)
-(** [types_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
+(** [type_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
if t1 = t2 or t1 is abstract and not t2.
*)
let (type_eff_are_compatible : type_eff -> type_eff -> bool) =
@@ -448,12 +404,12 @@ let (type_eff_are_compatible : type_eff -> type_eff -> bool) =
| External_type_eff _, _ -> true
| t1, t2 -> t1 = t2
-let (var_eff_ext_are_compatible : var_info_eff -> var_info_eff -> bool) =
+let (var_eff_are_compatible : var_info_eff -> var_info_eff -> bool) =
fun v1 v2 ->
let type_is_ok =
match v1.var_type_eff, v2.var_type_eff with
- | External_type_eff_ext id1, External_type_eff_ext id2 -> id1 = id2
- | External_type_eff_ext _, _ -> true
+ | External_type_eff id1, External_type_eff id2 -> id1 = id2
+ | External_type_eff _, _ -> true
| t1, t2 -> t1 = t2
in
type_is_ok && v1.var_clock_eff = v2.var_clock_eff
@@ -469,7 +425,7 @@ let (type_of_const_eff: const_eff -> type_eff) =
function
| Bool_const_eff v -> Bool_type_eff
| Int_const_eff v -> Int_type_eff
- | Real_const_eff v -> Real_type_eff
+ | Real_const_eff v -> Real_type_eff
| Extern_const_eff (s, teff, vopt) -> teff
| Enum_const_eff (s, teff) -> teff
| Struct_const_eff (fl, teff) -> teff
@@ -478,7 +434,7 @@ let (type_of_const_eff: const_eff -> type_eff) =
let (type_eff_of_left_eff: left_eff -> type_eff) =
function
- | LeftVarEff (vi_eff,lxm) -> type_eff_ext_to_type_eff vi_eff.var_type_eff
+ | LeftVarEff (vi_eff,lxm) -> vi_eff.var_type_eff
| LeftFieldEff(_, _, t_eff) -> t_eff
| LeftArrayEff(_, _, t_eff) -> t_eff
| LeftSliceEff(_, _, t_eff) -> t_eff
diff --git a/src/compiledDataDump.ml b/src/compiledDataDump.ml
index 240722366ac546a4e449febd470496cc7c90c152..fd2b1a687900e58b7b372fddf7b3d2b2971816b0 100644
--- a/src/compiledDataDump.ml
+++ b/src/compiledDataDump.ml
@@ -36,21 +36,21 @@ and string_of_const_eff_opt = function
| None -> ""
| Some val_exp_eff -> string_of_const_eff val_exp_eff
-and string_of_type_eff_ext = function
- | Bool_type_eff_ext -> "bool"
- | Int_type_eff_ext -> "int"
- | Real_type_eff_ext -> "real"
- | External_type_eff_ext i -> long i
- | Enum_type_eff_ext (i, sl) ->
+and string_of_type_eff = function
+ | Bool_type_eff -> "bool"
+ | Int_type_eff -> "int"
+ | Real_type_eff -> "real"
+ | External_type_eff i -> long i
+ | 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)) ^ "}"
- | Array_type_eff_ext (ty, sz) -> sprintf "%s^%d" (string_of_type_eff_ext ty) sz
- | Struct_type_eff_ext (name, fl) ->
+ | 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_ext, const_eff_opt)) =
+ let f sep acc (id, (type_eff, const_eff_opt)) =
acc ^ sep ^ (Ident.to_string id) ^ " : " ^
- (string_of_type_eff_ext type_eff_ext) ^
+ (string_of_type_eff type_eff) ^
match const_eff_opt with
None -> ""
| Some ce -> " (" ^ (string_of_const_eff ce) ^ ")"
@@ -61,20 +61,12 @@ and string_of_type_eff_ext = function
| Any -> "a"
| Overload -> "o"
+
and (type_eff_list_to_string :type_eff list -> string) =
fun tel ->
let str_l = List.map string_of_type_eff tel in
- String.concat "*" str_l
-
-and (type_eff_ext_list_to_string :type_eff_ext list -> string) =
- fun tel ->
- let str_l = List.map string_of_type_eff_ext tel in
String.concat "*" str_l
-
-and string_of_type_eff teff = string_of_type_eff_ext (type_eff_to_type_eff_ext teff)
-
-
and string_of_type_eff_list = function
| [] -> ""
| [x] -> string_of_type_eff x
@@ -98,16 +90,16 @@ and static_arg2string (sa : static_arg_eff) =
and (string_of_var_info_eff: var_info_eff -> string) =
fun x ->
- (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff_ext x.var_type_eff)
+ (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)
-and string_of_decl_ext var_info_eff =
+and string_of_decl var_info_eff =
(Ident.to_string var_info_eff.var_name_eff) ^ ":" ^
- (string_of_type_eff_ext var_info_eff.var_type_eff) ^
+ (string_of_type_eff var_info_eff.var_type_eff) ^
(string_of_clock var_info_eff.var_clock_eff)
-and (string_of_type_decl_list_ext : var_info_eff list -> string -> string) =
+and (string_of_type_decl_list : var_info_eff list -> string -> string) =
fun tel sep ->
- let str = String.concat sep (List.map string_of_decl_ext tel) in
+ let str = String.concat sep (List.map string_of_decl tel) in
str
@@ -267,8 +259,8 @@ and (profile_of_node_exp_eff: node_exp_eff -> string) =
((if neff.def_eff = ExternEff then "extern " else "") ^
(if neff.has_mem_eff then "node " else "function ") ^
(string_of_node_key neff.node_key_eff) ^
- "(" ^ (string_of_type_decl_list_ext neff.inlist_eff "; ") ^ ") returns (" ^
- (string_of_type_decl_list_ext neff.outlist_eff "; ") ^ ");\n")
+ "(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
+ (string_of_type_decl_list neff.outlist_eff "; ") ^ ");\n")
and (string_of_node_def : node_def_eff -> string list) =
function
@@ -312,7 +304,7 @@ and (node_of_node_exp_eff: node_exp_eff -> string) =
| BodyEff _ ->
((match neff.loclist_eff with None -> "" | Some [] -> ""
| Some l ->
- "var\n " ^ (string_of_type_decl_list_ext l ";\n ") ^ ";\n") ^
+ "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 " ^
diff --git a/src/evalConst.ml b/src/evalConst.ml
index b9b77e4320b654f9a131b96f4e5d0cb20b90b9a0..9c2e9702c190607b2695762b6a061da0c08ba5b2 100644
--- a/src/evalConst.ml
+++ b/src/evalConst.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 05/06/2008 (at 10:43) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:03) by Erwan Jahier> *)
open Printf
@@ -485,7 +485,7 @@ and eval_array_slice (env : id_solver) (sl : slice_info) (sz : int) (lxm : Lxm.t
| [Int_const_eff s] -> s (* ok *)
| [x] -> raise(EvalArray_error(
sprintf "bad array step, int expected but get %s"
- (CompiledDataDump.string_of_type_eff(type_of_const_eff x))))
+ (CompiledDataDump.string_of_type_eff (type_of_const_eff x))))
| _ -> raise(EvalArray_error(
sprintf "bad array step, int expected but get a tuple"))
)
diff --git a/src/evalType.ml b/src/evalType.ml
index 88156fbb1b84e09ca913a77c8d998166d5f05679..c1e4c90a462dd1c1b8c272a29c82b2967a8078db 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 06/06/2008 (at 10:24) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:17) by Erwan Jahier> *)
open Predef
@@ -19,7 +19,7 @@ let rec (f : id_solver -> val_exp_eff -> type_eff list) =
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 ->
@@ -34,17 +34,12 @@ and (eval_by_pos_type :
| CALL_eff node_exp_eff ->
let lto = List.map (fun v -> v.var_type_eff) node_exp_eff.it.outlist_eff in
- (try List.map type_eff_ext_to_type_eff lto
- with Polymorphic | Overloaded -> assert false)
-
+ lto
+
| IDENT_eff id -> (
(* [id] migth be a constant, but also a variable *)
try [type_of_const_eff (id_solver.id2const id lxm)]
- with _ -> [
- try
- type_eff_ext_to_type_eff (id_solver.id2var id lxm).var_type_eff
- with Polymorphic | Overloaded -> assert false
- ]
+ with _ -> [(id_solver.id2var id lxm).var_type_eff]
)
| WITH_eff -> (
match args with
diff --git a/src/evalType.mli b/src/evalType.mli
index 068b8ae97adbfb3f129bc46d17dfbfb1378661bf..3f4a817c0b6ae106d064e9729155e6baef341153 100644
--- a/src/evalType.mli
+++ b/src/evalType.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 14/04/2008 (at 17:58) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:05) by Erwan Jahier> *)
(** Evaluates the type of an expression. *)
val f : CompiledData.id_solver -> CompiledData.val_exp_eff ->
diff --git a/src/getEff.ml b/src/getEff.ml
index 43826cc801e150524bd21e79b51b2f56ecb00743..4c4e55eb7871320b7c5deeed48b37a0a9f984bfc 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 06/06/2008 (at 15:31) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:03) by Erwan Jahier> *)
open Lxm
diff --git a/src/getEff.mli b/src/getEff.mli
index 20fc2987222c20f3037be3c423dc2141d1447ac9..ff5df7dcd8ca85a516c83d6e24bd7dacccfddba7 100644
--- a/src/getEff.mli
+++ b/src/getEff.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 05/06/2008 (at 16:11) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:05) by Erwan Jahier> *)
(** This module defines functions that translate SyntaxTreeCore datatypes into
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 701839f39221f59529be90d4430b112e8005048f..dda561aa2da5e06552831d3a830993b56568453a 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 06/06/2008 (at 15:46) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:16) by Erwan Jahier> *)
open Lxm
@@ -483,10 +483,10 @@ and (node_check_interface_do: t -> CompiledData.node_key -> Lxm.t ->
fun this nk lxm symbols pn node_def ->
let body_node_exp_eff = node_check this nk lxm in
let prov_node_exp_eff = node_check_do this nk lxm symbols true pn node_def in
- (** [types_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
+ (** [type_eff_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
if t1 = t2 or t1 is abstract and and t2.
*)
- let type_is_comp v1 v2 = CompiledData.var_eff_ext_are_compatible v1 v2 in
+ let type_is_comp v1 v2 = CompiledData.var_eff_are_compatible v1 v2 in
if
prov_node_exp_eff.node_key_eff = body_node_exp_eff.node_key_eff &&
(List.for_all2 type_is_comp
@@ -565,8 +565,8 @@ and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
let vi_eff = {
var_name_eff = vi.it.var_name;
var_nature_eff = vi.it.var_nature;
- var_type_eff = type_eff_to_type_eff_ext t_eff;
- var_clock_eff = c_eff;
+ var_type_eff = t_eff;
+ var_clock_eff = c_eff;
}
in
Hashtbl.add local_env.lenv_types id t_eff;
@@ -730,8 +730,7 @@ and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
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 = type_eff_to_type_eff_ext(
- GetEff.typ node_id_solver vi.it.var_type)
+ 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
diff --git a/src/parser.mly b/src/parser.mly
index 95e66ceeedcb0a48540ef7df3c36ad335858cc71..4823570dd0a626826647dcdce0f2a1ad950639c9 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -6,334 +6,6 @@ open SyntaxTreeCore
open ParserUtils
-(**********************************************************************************)
-(* Interface avec SyntaxTree *)
-let idref_of_lxm lxm =
- try Lxm.flagit (Ident.idref_of_string (Lxm.str lxm)) lxm
- with _ ->
- print_string ("Parser.idref_of_lxm" ^(Lxm.str lxm));
- assert false
-
-
-(**********************************************************************************)
-(** add_info
------------------------------------------------------------------------
-Rôle :
- 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é
-*)
-let (add_info : (Ident.t, 'a srcflagged) Hashtbl.t ->
- string -> (* une string en cas d'erreur *)
- Lxm.t -> (* le lexeme en question *)
- 'a -> (* l'info en question *)
- unit) =
- 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)
- )
- )
- 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
-
- Most of the function below (treat_<something>) returns unit but modifies
- one or several of those tables.
-*)
-
-let (const_table:(Ident.t, const_info srcflagged) Hashtbl.t) = Hashtbl.create 50
-let (type_table :(Ident.t, type_info srcflagged) Hashtbl.t) = Hashtbl.create 50
-let (node_table :(Ident.t, node_info srcflagged) Hashtbl.t) = Hashtbl.create 50
-let (def_list : item_ident list ref) = ref []
-
-
-(**********************************************************************************)
-(** Traitement des listes d'idents avec valeur éventuelle
- (constantes, champs de struct etc...)
-*)
-
-let (lexeme_to_ident_flagged: Lxm.t -> Ident.t Lxm.srcflagged) =
- fun x -> {it = (Lxm.id x); src = x }
-
-let (lexeme_to_pack_name_flagged:Lxm.t -> Ident.pack_name Lxm.srcflagged) =
- fun x -> {it = (Ident.pack_name_of_string (Lxm.str x)); src = x }
-
-
-(* Listes d'idents typés et (éventuellement) valués *)
-type id_valopt = (Lxm.t * type_exp * val_exp option)
-
-(* Pas de valeur : le type distribue sur une liste d'ident *)
-let id_valopt_list_of_id_list (idlist : Lxm.t list) (texp : type_exp) =
- let treat_id (id : Lxm.t) = (id, texp, None) in
- List.map treat_id idlist
-
-(* Avec valeur : il ne doit y avoir qu'un seul ident *)
-let id_valopt_of_id_val (id : Lxm.t) (texp : type_exp) (vexp : val_exp) = (* -> unit *)
- (id, texp, Some vexp)
-
-let treat_external_const_list lst typ = (* -> unit *)
- let f = function lxm ->
- add_info const_table "constant" lxm (ExternalConst ((Lxm.id lxm), typ, None));
- def_list := (ConstItem (Lxm.id lxm)) :: !def_list
- in
- List.iter f lst
-
-
-let treat_defined_const lxm typ exp = (* -> unit *)
- add_info const_table "constant" lxm (DefinedConst ((Lxm.id lxm) , typ, exp));
- def_list := (ConstItem (Lxm.id lxm)) :: !def_list
-
-let treat_external_type_list lxmlst = (* -> unit *)
- let f = function lxm ->
- add_info type_table "type" lxm (ExternalType (Lxm.id lxm)) ;
- def_list := (TypeItem (Lxm.id lxm)) :: !def_list
- in
- List.iter f lxmlst
-
-
-let treat_aliased_type lxm typexp = (* -> unit *)
- add_info type_table "type" lxm (AliasedType ((Lxm.id lxm), typexp));
- def_list := (TypeItem (Lxm.id lxm)) :: !def_list
-
-
-(**********************************************************************************)
-(* Traitement d'un type énuméré *)
-let (treat_enum_type : Lxm.t -> Lxm.t list -> unit) =
- fun
- typlxm (* le lexeme du type *)
- cstlxmlst (* liste des lexemes des valeurs *)
- ->
- let cstnamelist = List.map lexeme_to_ident_flagged cstlxmlst in
- (* Enfin, on introduit la définition du type *)
- let typstr = Lxm.id typlxm in
- add_info type_table "type" typlxm (EnumType (typstr, cstnamelist));
- def_list := (TypeItem typstr) :: !def_list
-
-(**********************************************************************************)
-(* Traitement d'un type structure *)
-let (make_struct_type_info : Lxm.t -> id_valopt list (* la liste des champs *) ->
- struct_type_info) =
- fun typlxm flexlist ->
- (* On anticipe la construction de la table de champs *)
- let ftab = Hashtbl.create 50 in
- 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 *)
- in
- let flst = List.map put_in_ftab flexlist in
- { st_name = Lxm.id typlxm ; st_flist = flst ; st_ftable = ftab }
-
-
-(**********************************************************************************)
-let treat_struct_type
- (typlxm : Lxm.t) (* le lexeme du nom de type *)
- (flexlist: id_valopt list) (* la liste des champs *)
- = (* sortie: unit *)
- let typstr = Lxm.id typlxm in
- let typinfo = StructType
- (make_struct_type_info typlxm flexlist)
- in
- (* met l'info dans la table des types *)
- add_info type_table "type" typlxm typinfo ;
- def_list := (TypeItem typstr) :: !def_list
-
-
-(**********************************************************************************)
-(********************************************)
-(* Déclarations de vars et params de noeuds *)
-(********************************************)
-(*
-Un peu coton à cause des types, clocks,
-et de la syntaxe laxiste sur la distribution
-de ces flags dans les déclarations de variables !
-On utilise un artifice local pour
-homogénéiser le traitements de listes de vars :
-- clocked_ids list
-*)
-type typed_ids = (Lxm.t list * type_exp)
-type clocked_ids = (typed_ids list * clock_exp)
-
-let (clocked_ids_to_var_infos : var_nature ->
- (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
- var_info srcflagged list) =
- fun vnat vdefs ->
- let makevar lxm te ce =
- Lxm.flagit
- {
- var_nature = vnat ;
- var_name = (Lxm.id lxm) ;
- var_type = te ;
- var_clock = ce ;
- }
- lxm
- in
- ParserUtils.flat_twice_flagged_list vdefs makevar
-
-
-(**********************************************************************************)
-let (treat_node_decl : bool -> Lxm.t -> static_param srcflagged list ->
- clocked_ids list (* entrées *) ->
- clocked_ids list (* sorties *) ->
- clocked_ids list (* locales *) ->
- pragma list ->
- (val_exp srcflagged) list (* assserts *) ->
- (eq_info srcflagged) list (* liste des equations *) ->
- unit
- ) =
- fun has_memory nlxm statics indefs outdefs locdefs _pragma asserts eqs ->
- let vtable = Hashtbl.create 50 in
- 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 ->
- 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
- }
- in
- add_info vtable "variable" lxm vinfo;
- Lxm.flagit vinfo lxm
- in
- (ParserUtils.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
- and locvars = treat_vars locdefs VarLocal
- in
- let vars = build_node_var invars outvars (Some locvars) in
- let nstr = Lxm.id nlxm in
- let ninfo = {
- name = nstr;
- static_params = statics;
- vars = Some vars;
- def = Body { asserts = asserts ; eqs = eqs };
- has_mem = has_memory;
- is_safe = true;
- }
- in
- add_info node_table "node" nlxm ninfo;
- def_list := (NodeItem (nstr,statics)) :: !def_list
-
-
-(**********************************************************************************)
-let (treat_node_alias : bool -> Lxm.t -> static_param srcflagged list ->
- (var_info srcflagged list * var_info srcflagged list) option ->
- node_exp srcflagged -> unit) =
- fun has_memory nlxm statics node_profile value ->
- let nstr = Lxm.id nlxm in
- let vars =
- match node_profile with
- | None -> None
- | Some (invars,outvars) -> Some (build_node_var invars outvars None)
- in
- let ninfo = {
- name = nstr;
- static_params = statics;
- vars = vars;
- def = Alias (flagit (CALL_n value) value.src);
- has_mem = has_memory;
- is_safe = true;
- }
- in
- add_info node_table "(alias) node" nlxm ninfo;
- def_list := (NodeItem (nstr,statics)) :: !def_list
-
-
-
-(**********************************************************************************)
-(* Traitement d'un noeud abstrait *)
-
-let treat_abstract_or_extern_node_do (* cf the profile of [treat_abstract_node] *)
- has_memory lxm inpars outpars is_abstract =
- let (invars, outvars : var_info srcflagged list * var_info srcflagged list) =
- clocked_ids_to_var_infos VarInput inpars,
- clocked_ids_to_var_infos VarOutput outpars
- in
- let vars = build_node_var invars outvars None in
- let xn = {
- name = Lxm.id lxm;
- static_params = [];
- vars = Some vars;
- def = if is_abstract then Abstract else Extern;
- has_mem = has_memory;
- is_safe = true;
- }
- in
- xn
-
-let (treat_abstract_node : bool -> Lxm.t ->
- (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
- (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
- item_info Lxm.srcflagged) =
- fun has_memory lxm inpars outpars ->
- Lxm.flagit
- (NodeInfo (treat_abstract_or_extern_node_do has_memory lxm inpars outpars true))
- lxm
-
-
-(**********************************************************************************)
-let (treat_external_node : bool -> Lxm.t ->
- (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
- (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
- unit
- ) =
- 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
- in
- let statics = [] in (* no static args for external node (for now at least) *)
- add_info node_table "(extern) node" ext_nodelxm ninfo ;
- def_list := (NodeItem (Lxm.id (ext_nodelxm),statics)) :: !def_list
-
-(**********************************************************************************)
-let (threat_slice_start : Lxm.t -> val_exp -> val_exp option -> slice_info srcflagged) =
- fun lxm last step ->
- 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 [])
- with _ ->
- 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
-
-
-
-
(**********************************************************************************)
(**********************************************************************************)
(**********************************************************************************)
diff --git a/src/parserUtils.ml b/src/parserUtils.ml
index 6c58533c5998828e5e1da10ae6220fa60304d677..c2d48e1d528afef9270e995f29ecffaa90ec8de7 100644
--- a/src/parserUtils.ml
+++ b/src/parserUtils.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 03/06/2008 (at 14:40) by Erwan Jahier> *)
+(** Time-stamp: <modified the 06/06/2008 (at 18:01) by Erwan Jahier> *)
@@ -7,6 +7,7 @@
open Lxm
open SyntaxTree
open SyntaxTreeCore
+open Predef
let (build_node_var : var_info srcflagged list -> var_info srcflagged list ->
var_info srcflagged list option -> node_vars) =
@@ -142,4 +143,330 @@ let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )
open Ident
+(**********************************************************************************)
+(* Interface avec SyntaxTree *)
+let idref_of_lxm lxm =
+ try Lxm.flagit (Ident.idref_of_string (Lxm.str lxm)) lxm
+ with _ ->
+ print_string ("Parser.idref_of_lxm" ^(Lxm.str lxm));
+ assert false
+
+
+(**********************************************************************************)
+(** add_info
+-----------------------------------------------------------------------
+Rôle :
+ 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é
+*)
+let (add_info : (Ident.t, 'a srcflagged) Hashtbl.t ->
+ string -> (* une string en cas d'erreur *)
+ Lxm.t -> (* le lexeme en question *)
+ 'a -> (* l'info en question *)
+ unit) =
+ 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)
+ )
+ )
+ 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
+
+ Most of the function below (treat_<something>) returns unit but modifies
+ one or several of those tables.
+*)
+
+let (const_table:(Ident.t, const_info srcflagged) Hashtbl.t) = Hashtbl.create 50
+let (type_table :(Ident.t, type_info srcflagged) Hashtbl.t) = Hashtbl.create 50
+let (node_table :(Ident.t, node_info srcflagged) Hashtbl.t) = Hashtbl.create 50
+let (def_list : item_ident list ref) = ref []
+
+
+(**********************************************************************************)
+(** Traitement des listes d'idents avec valeur éventuelle
+ (constantes, champs de struct etc...)
+*)
+
+let (lexeme_to_ident_flagged: Lxm.t -> Ident.t Lxm.srcflagged) =
+ fun x -> {it = (Lxm.id x); src = x }
+
+let (lexeme_to_pack_name_flagged:Lxm.t -> Ident.pack_name Lxm.srcflagged) =
+ fun x -> {it = (Ident.pack_name_of_string (Lxm.str x)); src = x }
+
+
+(* Listes d'idents typés et (éventuellement) valués *)
+type id_valopt = (Lxm.t * type_exp * val_exp option)
+
+(* Pas de valeur : le type distribue sur une liste d'ident *)
+let id_valopt_list_of_id_list (idlist : Lxm.t list) (texp : type_exp) =
+ let treat_id (id : Lxm.t) = (id, texp, None) in
+ List.map treat_id idlist
+
+(* Avec valeur : il ne doit y avoir qu'un seul ident *)
+let id_valopt_of_id_val (id : Lxm.t) (texp : type_exp) (vexp : val_exp) = (* -> unit *)
+ (id, texp, Some vexp)
+
+let treat_external_const_list lst typ = (* -> unit *)
+ let f = function lxm ->
+ add_info const_table "constant" lxm (ExternalConst ((Lxm.id lxm), typ, None));
+ def_list := (ConstItem (Lxm.id lxm)) :: !def_list
+ in
+ List.iter f lst
+
+
+let treat_defined_const lxm typ exp = (* -> unit *)
+ add_info const_table "constant" lxm (DefinedConst ((Lxm.id lxm) , typ, exp));
+ def_list := (ConstItem (Lxm.id lxm)) :: !def_list
+
+let treat_external_type_list lxmlst = (* -> unit *)
+ let f = function lxm ->
+ add_info type_table "type" lxm (ExternalType (Lxm.id lxm)) ;
+ def_list := (TypeItem (Lxm.id lxm)) :: !def_list
+ in
+ List.iter f lxmlst
+
+
+let treat_aliased_type lxm typexp = (* -> unit *)
+ add_info type_table "type" lxm (AliasedType ((Lxm.id lxm), typexp));
+ def_list := (TypeItem (Lxm.id lxm)) :: !def_list
+
+
+(**********************************************************************************)
+(* Traitement d'un type énuméré *)
+let (treat_enum_type : Lxm.t -> Lxm.t list -> unit) =
+ fun
+ typlxm (* le lexeme du type *)
+ cstlxmlst (* liste des lexemes des valeurs *)
+ ->
+ let cstnamelist = List.map lexeme_to_ident_flagged cstlxmlst in
+ (* Enfin, on introduit la définition du type *)
+ let typstr = Lxm.id typlxm in
+ add_info type_table "type" typlxm (EnumType (typstr, cstnamelist));
+ def_list := (TypeItem typstr) :: !def_list
+
+(**********************************************************************************)
+(* Traitement d'un type structure *)
+let (make_struct_type_info : Lxm.t -> id_valopt list (* la liste des champs *) ->
+ struct_type_info) =
+ fun typlxm flexlist ->
+ (* On anticipe la construction de la table de champs *)
+ let ftab = Hashtbl.create 50 in
+ 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 *)
+ in
+ let flst = List.map put_in_ftab flexlist in
+ { st_name = Lxm.id typlxm ; st_flist = flst ; st_ftable = ftab }
+
+
+(**********************************************************************************)
+let treat_struct_type
+ (typlxm : Lxm.t) (* le lexeme du nom de type *)
+ (flexlist: id_valopt list) (* la liste des champs *)
+ = (* sortie: unit *)
+ let typstr = Lxm.id typlxm in
+ let typinfo = StructType
+ (make_struct_type_info typlxm flexlist)
+ in
+ (* met l'info dans la table des types *)
+ add_info type_table "type" typlxm typinfo ;
+ def_list := (TypeItem typstr) :: !def_list
+
+(**********************************************************************************)
+(********************************************)
+(* Déclarations de vars et params de noeuds *)
+(********************************************)
+(*
+Un peu coton à cause des types, clocks,
+et de la syntaxe laxiste sur la distribution
+de ces flags dans les déclarations de variables !
+On utilise un artifice local pour
+homogénéiser le traitements de listes de vars :
+- clocked_ids list
+*)
+type typed_ids = (Lxm.t list * type_exp)
+type clocked_ids = (typed_ids list * clock_exp)
+
+let (clocked_ids_to_var_infos : var_nature ->
+ (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
+ var_info srcflagged list) =
+ fun vnat vdefs ->
+ let makevar lxm te ce =
+ Lxm.flagit
+ {
+ var_nature = vnat ;
+ var_name = (Lxm.id lxm) ;
+ var_type = te ;
+ var_clock = ce ;
+ }
+ lxm
+ in
+ flat_twice_flagged_list vdefs makevar
+
+
+(**********************************************************************************)
+let (treat_node_decl : bool -> Lxm.t -> static_param srcflagged list ->
+ clocked_ids list (* entrées *) ->
+ clocked_ids list (* sorties *) ->
+ clocked_ids list (* locales *) ->
+ pragma list ->
+ (val_exp srcflagged) list (* assserts *) ->
+ (eq_info srcflagged) list (* liste des equations *) ->
+ unit
+ ) =
+ fun has_memory nlxm statics indefs outdefs locdefs _pragma asserts eqs ->
+ let vtable = Hashtbl.create 50 in
+ 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 ->
+ 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
+ }
+ in
+ 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
+ and locvars = treat_vars locdefs VarLocal
+ in
+ let vars = build_node_var invars outvars (Some locvars) in
+ let nstr = Lxm.id nlxm in
+ let ninfo = {
+ name = nstr;
+ static_params = statics;
+ vars = Some vars;
+ def = Body { asserts = asserts ; eqs = eqs };
+ has_mem = has_memory;
+ is_safe = true;
+ }
+ in
+ add_info node_table "node" nlxm ninfo;
+ def_list := (NodeItem (nstr,statics)) :: !def_list
+
+
+(**********************************************************************************)
+let (treat_node_alias : bool -> Lxm.t -> static_param srcflagged list ->
+ (var_info srcflagged list * var_info srcflagged list) option ->
+ node_exp srcflagged -> unit) =
+ fun has_memory nlxm statics node_profile value ->
+ let nstr = Lxm.id nlxm in
+ let vars =
+ match node_profile with
+ | None -> None
+ | Some (invars,outvars) -> Some (build_node_var invars outvars None)
+ in
+ let ninfo = {
+ name = nstr;
+ static_params = statics;
+ vars = vars;
+ def = Alias (flagit (CALL_n value) value.src);
+ has_mem = has_memory;
+ is_safe = true;
+ }
+ in
+ add_info node_table "(alias) node" nlxm ninfo;
+ def_list := (NodeItem (nstr,statics)) :: !def_list
+
+
+
+(**********************************************************************************)
+(* Traitement d'un noeud abstrait *)
+
+let treat_abstract_or_extern_node_do (* cf the profile of [treat_abstract_node] *)
+ has_memory lxm inpars outpars is_abstract =
+ let (invars, outvars : var_info srcflagged list * var_info srcflagged list) =
+ clocked_ids_to_var_infos VarInput inpars,
+ clocked_ids_to_var_infos VarOutput outpars
+ in
+ let vars = build_node_var invars outvars None in
+ let xn = {
+ name = Lxm.id lxm;
+ static_params = [];
+ vars = Some vars;
+ def = if is_abstract then Abstract else Extern;
+ has_mem = has_memory;
+ is_safe = true;
+ }
+ in
+ xn
+
+let (treat_abstract_node : bool -> Lxm.t ->
+ (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
+ (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
+ item_info Lxm.srcflagged) =
+ fun has_memory lxm inpars outpars ->
+ Lxm.flagit
+ (NodeInfo (treat_abstract_or_extern_node_do has_memory lxm inpars outpars true))
+ lxm
+
+
+(**********************************************************************************)
+let (treat_external_node : bool -> Lxm.t ->
+ (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
+ (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list ->
+ unit
+ ) =
+ 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
+ in
+ let statics = [] in (* no static args for external node (for now at least) *)
+ add_info node_table "(extern) node" ext_nodelxm ninfo ;
+ def_list := (NodeItem (Lxm.id (ext_nodelxm),statics)) :: !def_list
+
+(**********************************************************************************)
+let (threat_slice_start : Lxm.t -> val_exp -> val_exp option -> slice_info srcflagged) =
+ fun lxm last step ->
+ 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 [])
+ with _ ->
+ 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
+
+
+
diff --git a/src/predefEvalType.ml b/src/predefEvalType.ml
index ffd0ea1901282c892dcb010653fb06e4ca6c9cc2..b95b27a21e59f368d7c90b7a3923077f112bb986 100644
--- a/src/predefEvalType.ml
+++ b/src/predefEvalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 05/06/2008 (at 17:03) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:09) by Erwan Jahier> *)
open Predef
open SyntaxTreeCore
@@ -41,9 +41,9 @@ let (arity_error : 'a list -> string -> 'b) =
(*********************************************************************************)
(* a few local alias to make the node profile below more readable. *)
-let i = Int_type_eff_ext
-let r = Real_type_eff_ext
-let b = Bool_type_eff_ext
+let i = Int_type_eff
+let r = Real_type_eff
+let b = Bool_type_eff
let id str = Ident.of_string str
(** A few useful type profiles for simple operators *)
@@ -72,9 +72,9 @@ let ooo_profile = [(id "i1",Overload);(id "i2",Overload)], [(id "o",Overload)]
(** iterators profiles *)
(* [type_to_array_type [x1;...;xn] c] returns the array type [x1^c;...;xn^c] *)
-let (type_to_array_type: var_info_eff list -> int -> (Ident.t * type_eff_ext) list) =
+let (type_to_array_type: var_info_eff list -> int -> (Ident.t * type_eff) list) =
fun l c ->
- List.map (fun vi -> vi.var_name_eff, Array_type_eff_ext(vi.var_type_eff,c)) l
+ List.map (fun vi -> vi.var_name_eff, Array_type_eff(vi.var_type_eff,c)) l
(* Extract the node and the constant from a list of static args *)
let (get_node_and_constant:static_arg_eff list -> node_exp_eff * int)=
@@ -119,8 +119,8 @@ let fillred_profile =
(* if they are not equal, they migth be unifiable *)
match Unify.f [t1] [t2] with
| Equal -> (lti,lto)
- | Unif t -> (List.map (fun (id,tid) -> id, subst_type_ext t tid) lti,
- List.map (fun (id,tid) -> id, subst_type_ext t tid) lto)
+ | Unif t -> (List.map (fun (id,tid) -> id, subst_type t tid) lti,
+ List.map (fun (id,tid) -> id, subst_type t tid) lto)
| Ko(msg) -> raise (Compile_error(lxm, msg))
@@ -155,10 +155,10 @@ let boolred_profile =
| _ -> 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_ext(Bool_type_eff_ext,k))], [id "o", b]
+ [id "i", (Array_type_eff(Bool_type_eff,k))], [id "o", b]
-type node_profile = (Ident.t * type_eff_ext) list * (Ident.t * type_eff_ext) list
+type node_profile = (Ident.t * type_eff) list * (Ident.t * type_eff) list
let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
fun op lxm sargs -> match op with
@@ -235,7 +235,8 @@ let (f : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
(* 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")
+ match ceff with (Bool_type_eff) ->
+ acc | _ -> (type_error [ceff] "bool")
in
List.fold_left check_nary_iter () (List.flatten ll);
[Bool_type_eff]
@@ -244,17 +245,17 @@ let (f : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
let node_eff = make_node_exp_eff op lxm sargs in
let lti = List.map (fun v -> v.var_type_eff) node_eff.inlist_eff
and lto = List.map (fun v -> v.var_type_eff) node_eff.outlist_eff in
- let rec (subst_type : type_eff -> type_eff_ext -> type_eff) =
- fun t teff_ext -> match teff_ext with
- (* substitutes [t] in [teff_ext] *)
- | Bool_type_eff_ext -> Bool_type_eff
- | Int_type_eff_ext -> Int_type_eff
- | Real_type_eff_ext -> Real_type_eff
- | External_type_eff_ext l -> External_type_eff l
- | Enum_type_eff_ext(l,el) -> Enum_type_eff(l,el)
- | Array_type_eff_ext(teff_ext,i) ->
- Array_type_eff(subst_type t teff_ext, i)
- | Struct_type_eff_ext(l, fl) ->
+ let rec (subst_type : type_eff -> type_eff -> type_eff) =
+ fun t teff -> match teff with
+ (* substitutes [t] in [teff] *)
+ | Bool_type_eff -> Bool_type_eff
+ | Int_type_eff -> Int_type_eff
+ | Real_type_eff -> Real_type_eff
+ | External_type_eff l -> External_type_eff l
+ | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
+ | Array_type_eff(teff,i) ->
+ Array_type_eff(subst_type t teff, i)
+ | Struct_type_eff(l, fl) ->
Struct_type_eff(
l,
List.map
@@ -263,27 +264,27 @@ let (f : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
| Any
| Overload -> t
in
- let l = List.map type_eff_to_type_eff_ext (List.flatten ll) 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 Unify.f lti l with
- | Equal -> List.map type_eff_ext_to_type_eff lto
+ | Equal -> lto
| Unif Any ->
type_error2
- (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti)
+ (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti)
"could not instanciate polymorphic type"
| Unif Overload ->
type_error2
- (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti)
+ (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti)
"could not instanciate overloaded type"
| Unif t ->
- List.map (subst_type (type_eff_ext_to_type_eff t)) lto
+ List.map (subst_type t) lto
| Ko(str) ->
- type_error2 (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti) str
+ type_error2 (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti) str
diff --git a/src/predefEvalType.mli b/src/predefEvalType.mli
index 5aa96a26f76c54cae1ecea3fb5c5129ebde13da5..707db070778b16c53c315b9a39cb5a8bfa7ceb71 100644
--- a/src/predefEvalType.mli
+++ b/src/predefEvalType.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 05/06/2008 (at 10:42) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:05) by Erwan Jahier> *)
open CompiledData
diff --git a/src/predefSemantics.ml b/src/predefSemantics.ml
index e07887a175e87347fa38531849fd2651be76cc62..6f10ce6f47611e2a9eec0efeb049f99d14f8afd9 100644
--- a/src/predefSemantics.ml
+++ b/src/predefSemantics.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 03/06/2008 (at 14:53) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:04) by Erwan Jahier> *)
open Predef
@@ -63,9 +63,9 @@ let not_evaluable op l =
(*********************************************************************************)
(* a few local alias to make the node profile below more readable. *)
-let i = Int_type_eff_ext
-let r = Real_type_eff_ext
-let b = Bool_type_eff_ext
+let i = Int_type_eff
+let r = Real_type_eff
+let b = Bool_type_eff
let id str = Ident.of_string str
(** A few useful type profiles for simple operators *)
@@ -95,9 +95,9 @@ let ooo_profile = [(id "i1",Overload);(id "i2",Overload)], [(id "o",Overload)]
(** iterators profiles *)
(* [type_to_array_type [x1;...;xn] c] returns the array type [x1^c;...;xn^c] *)
let (type_to_array_type:
- (Ident.t * type_eff_ext) list -> int -> (Ident.t * type_eff_ext) list) =
+ (Ident.t * type_eff) list -> int -> (Ident.t * type_eff) list) =
fun l c ->
- List.map (fun (id, teff) -> id, Array_type_eff_ext(teff,c)) l
+ List.map (fun (id, teff) -> id, Array_type_eff(teff,c)) l
(* Extract the node and the constant from a list of static args *)
let (get_node_and_constant:static_arg_eff list -> node_exp_eff * int)=
@@ -175,10 +175,10 @@ let boolred_profile =
| _ -> 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_ext(Bool_type_eff_ext,k))], [id "o", b]
+ [id "i", (Array_type_eff(Bool_type_eff,k))], [id "o", b]
-type node_profile = (Ident.t * type_eff_ext) list * (Ident.t * type_eff_ext) list
+type node_profile = (Ident.t * type_eff) list * (Ident.t * type_eff) list
let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
fun op lxm sargs -> match op with
@@ -258,17 +258,17 @@ let (type_eval : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
let node_eff = make_node_exp_eff op lxm sargs in
let lti = List.map (fun (id,t) -> t) node_eff.inlist_eff
and lto = List.map (fun (id,t) -> t) node_eff.outlist_eff in
- let rec (subst_type : type_eff -> type_eff_ext -> type_eff) =
+ let rec (subst_type : type_eff -> type_eff -> type_eff) =
fun t teff_ext -> match teff_ext with
(* substitutes [t] in [teff_ext] *)
- | Bool_type_eff_ext -> Bool_type_eff
- | Int_type_eff_ext -> Int_type_eff
- | Real_type_eff_ext -> Real_type_eff
- | External_type_eff_ext l -> External_type_eff l
- | Enum_type_eff_ext(l,el) -> Enum_type_eff(l,el)
- | Array_type_eff_ext(teff_ext,i) ->
+ | Bool_type_eff -> Bool_type_eff
+ | Int_type_eff -> Int_type_eff
+ | Real_type_eff -> Real_type_eff
+ | External_type_eff l -> External_type_eff l
+ | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
+ | Array_type_eff(teff_ext,i) ->
Array_type_eff(subst_type t teff_ext, i)
- | Struct_type_eff_ext(l, fl) ->
+ | Struct_type_eff(l, fl) ->
Struct_type_eff(
l,
List.map
@@ -277,29 +277,29 @@ let (type_eval : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
| Any
| Overload -> t
in
- let l = List.map type_eff_to_type_eff_ext (List.flatten ll) in
+ let l = List.map type_eff_to_type_eff (List.flatten ll) in
if (List.length l <> List.length lti) then
arity_error l (string_of_int (List.length lti))
else
match Unify.f lti l with
- | Equal -> List.map type_eff_ext_to_type_eff lto
+ | Equal -> List.map type_eff_to_type_eff lto
| Unif Any ->
type_error2
- (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti)
+ (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti)
"could not instanciate polymorphic type"
| Unif Overload ->
type_error2
- (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti)
+ (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti)
"could not instanciate overloaded type"
| Unif t ->
- List.map (subst_type (type_eff_ext_to_type_eff t)) lto
+ List.map (subst_type (type_eff_to_type_eff t)) lto
| Ko(str) ->
- type_error2 (CompiledDataDump.type_eff_ext_list_to_string l)
- (CompiledDataDump.type_eff_ext_list_to_string lti) str
+ type_error2 (CompiledDataDump.type_eff_list_to_string l)
+ (CompiledDataDump.type_eff_list_to_string lti) str
(*********************************************************************************)
diff --git a/src/test/should_fail/semantics/bad_call03.lus b/src/test/should_fail/semantics/bad_call03.lus
index 38dd232b498204ca3e891d4883590866c0ba904f..d4b593193e63c1ff1f58a3eae5f68168299487a0 100644
--- a/src/test/should_fail/semantics/bad_call03.lus
+++ b/src/test/should_fail/semantics/bad_call03.lus
@@ -1,3 +1,4 @@
+-- Well, this one is acceptable after all...
node toto = map<<+, 3>>;
@@ -8,6 +9,7 @@ tel
node bad_call03(a,b:int^3; c,d:real^3) returns (x : int^3; y:real^3);
let
+
x = toto(a,b);
y = titi(c,d);
tel
diff --git a/src/test/should_work/NONREG/Watch.lus b/src/test/should_work/NONREG/Watch.lus
index 7e84adfc536d2c0b13dccdb6602aef89a7d146b4..25f6ab56b235e2eb538fb4bcc4b6fc6da13e36c0 100644
--- a/src/test/should_work/NONREG/Watch.lus
+++ b/src/test/should_work/NONREG/Watch.lus
@@ -138,6 +138,7 @@ extern function ALARM_TIME_TO_MAIN_DISPLAY
(time: ALARM_TIME_TYPE) returns (display: MAIN_DISPLAY_TYPE);
-- translation of "time" to the main display format
+
extern function MAKE_DISPLAY
(main: MAIN_DISPLAY_TYPE;
mini: MINI_DISPLAY_TYPE;
@@ -419,9 +420,14 @@ var main_display:MAIN_DISPLAY_TYPE;
mini_display:MINI_DISPLAY_TYPE;
alpha_display:string;
let
- display = MAKE_DISPLAY(main_display,mini_display,
- alpha_display, status,
- position_enhanced,labels);
+ display =
+ MAKE_DISPLAY(
+ main_display,
+ mini_display,
+ alpha_display,
+ status,
+ position_enhanced,
+ labels);
(main_display,mini_display,alpha_display) =
if mode_is_watch then
-- in watch mode, the main display shows the watch time, the mini
diff --git a/src/test/test.res.exp b/src/test/test.res.exp
index 49273b3a81cf7a6c10f735f065475d8749da1ec2..8f13836667445dc9fb89fc0b071a61387eb81626 100644
--- a/src/test/test.res.exp
+++ b/src/test/test.res.exp
@@ -14360,15 +14360,17 @@ End of Syntax table dump.
Exported types:
Exported constants:
Exported nodes:
+*** Error in file "should_fail/semantics/bad_call03.lus", line 7, col 5 to 5, token '=': type mismatch:
+*** 'real^3' (left-hand-side)
+*** is not compatible with
+*** 'o^3' (right-hand-side)
+
function bad_call03__toto(i1:o^3; i2:o^3) returns (o:o^3);
let
o = Lustre__map<<node Lustre__+, const 3>>(i1, i2);
tel
-- end of node bad_call03__toto
-*** oops: an internal error occurred in file evalType.ml, line 38, column 39
-*** when compiling lustre program should_fail/semantics/bad_call03.lus
-
----------------------------------------------------------------------
====> ../lus2lic -vl 3 --compile-all-items should_fail/semantics/bug.lus
Opening file /home/jahier/lus2lic/src/testshould_fail/semantics/bug.lus
@@ -14820,5 +14822,6 @@ type const2__t8 = int^3^7^8^9^3^8^8;
*** Error in file "should_fail/type/const2.lus", line 16, col 12 to 13, token '<>': type error:
*** type 'int*real' was provided whereas
*** type 'a*a' was expected
+***
*** int and real are not unifiable
diff --git a/src/unify.ml b/src/unify.ml
index 74f4db4c5ae0ed0eb14b9e4d8e4d4bc2d742051e..5a71fd1075e535099b10ae7dd0880110fbe6524d 100644
--- a/src/unify.ml
+++ b/src/unify.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 28/05/2008 (at 14:15) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:07) by Erwan Jahier> *)
open CompiledData
@@ -6,46 +6,46 @@ open CompiledData
(* exported *)
type t =
| Equal
- | Unif of type_eff_ext
+ | Unif of type_eff
| Ko of string (* a msg explaining why the unification failed *)
-let teff2str = CompiledDataDump.string_of_type_eff_ext
+let teff2str = CompiledDataDump.string_of_type_eff
-let (is_overloadable : type_eff_ext -> bool) = function
- | Int_type_eff_ext -> true
- | Real_type_eff_ext -> true
+let (is_overloadable : type_eff -> bool) = function
+ | Int_type_eff -> true
+ | Real_type_eff -> true
| _ -> false
(* [contains t1 t2] is true iff t2 appears in t1 *)
-let rec (contains : type_eff_ext -> type_eff_ext -> bool) =
+let rec (contains : type_eff -> type_eff -> bool) =
fun t1 t2 ->
if t1 = t2 then true else
match t1 with
| Any
| Overload
- | Bool_type_eff_ext
- | Int_type_eff_ext
- | Real_type_eff_ext
- | Enum_type_eff_ext(_,_)
- | External_type_eff_ext _ -> false
- | Array_type_eff_ext(teff,i) -> contains teff t2
- | Struct_type_eff_ext(l, fl) ->
+ | Bool_type_eff
+ | Int_type_eff
+ | Real_type_eff
+ | Enum_type_eff(_,_)
+ | External_type_eff _ -> false
+ | Array_type_eff(teff,i) -> contains teff t2
+ | Struct_type_eff(l, fl) ->
List.exists (fun (_,(teff,_)) -> contains teff t2) fl
(* exported *)
-let (f : type_eff_ext list -> type_eff_ext list -> t) =
- let rec (unify_type_eff : type_eff_ext -> type_eff_ext -> t) =
+let (f : type_eff list -> type_eff list -> t) = fun l1 l2 ->
+ let rec (unify_type_eff : type_eff -> type_eff -> t) =
fun t1 t2 ->
if t1 = t2 then Equal else
match (t1,t2) with
- | Array_type_eff_ext(teff_ext1,i1), Array_type_eff_ext(teff_ext2,i2) ->
- if i1 <> i2 then Ko "incompatible array size" else
+ | Array_type_eff(teff_ext1,i1), Array_type_eff(teff_ext2,i2) ->
+ if i1 <> i2 then Ko "\n*** incompatible array size" else
unify_type_eff teff_ext1 teff_ext2
- | Struct_type_eff_ext(l1, fl1), Struct_type_eff_ext(l2, fl2) ->
- if l1 <> l2 then Ko "incompatible structure" else
+ | Struct_type_eff(l1, fl1), Struct_type_eff(l2, fl2) ->
+ if l1 <> l2 then Ko "\n*** incompatible structure" else
let fl1 = List.map (fun (_,(te,_)) -> te) fl1
and fl2 = List.map (fun (_,(te,_)) -> te) fl2 in
List.fold_left2 unify_do_acc Equal fl1 fl2
@@ -56,7 +56,7 @@ let (f : type_eff_ext list -> type_eff_ext list -> t) =
| t, Any
| Any, t ->
if contains t Any || contains t Overload then
- Ko((teff2str t1) ^ " and " ^ (teff2str t2) ^
+ Ko(("\n*** " ^ teff2str t1) ^ " and " ^ (teff2str t2) ^
" are not unifiable (there is a cycle)")
else
Unif t
@@ -64,18 +64,18 @@ let (f : type_eff_ext list -> type_eff_ext list -> t) =
| t, Overload
| Overload, t ->
if contains t Any || contains t Overload then
- Ko((teff2str t1) ^ " and " ^ (teff2str t2) ^
+ Ko("\n*** " ^ (teff2str t1) ^ " and " ^ (teff2str t2) ^
" are not unifiable (there is a cycle)")
else if is_overloadable t then
Unif t
else
- Ko((teff2str t) ^ " should be an integer or a real")
+ Ko("\n*** " ^ (teff2str t) ^ " should be an integer or a real")
| _ ->
- Ko((teff2str t1) ^ " and " ^ (teff2str t2) ^
+ Ko("\n*** " ^ (teff2str t1) ^ " and " ^ (teff2str t2) ^
" are not unifiable")
- and (unify_do_acc: t -> type_eff_ext -> type_eff_ext -> t) =
+ and (unify_do_acc: t -> type_eff -> type_eff -> t) =
fun acc te1 te2 ->
match acc, unify_type_eff te1 te2 with
| Equal, Equal -> Equal
@@ -84,40 +84,41 @@ let (f : type_eff_ext list -> type_eff_ext list -> t) =
| Unif t, Equal
| Equal, Unif t -> Unif t
| Unif t1, Unif t2 -> if t1 = t2 then acc else
- Ko((teff2str t1) ^ " and " ^ (teff2str t2) ^
+ Ko("\n*** " ^ (teff2str t1) ^ " and " ^ (teff2str t2) ^
" are not unifiable")
in
- List.fold_left2 unify_do_acc Equal
+ assert (List.length l1 = List.length l2);
+ List.fold_left2 unify_do_acc Equal l1 l2
(* exported *)
-let rec (subst_type_ext : type_eff_ext -> type_eff_ext -> type_eff_ext) =
+let rec (subst_type : type_eff -> type_eff -> type_eff) =
fun t teff_ext -> match teff_ext with
(* substitutes [t] in [teff_ext] *)
- | Bool_type_eff_ext -> Bool_type_eff_ext
- | Int_type_eff_ext -> Int_type_eff_ext
- | Real_type_eff_ext -> Real_type_eff_ext
- | External_type_eff_ext l -> External_type_eff_ext l
- | Enum_type_eff_ext(l,el) -> Enum_type_eff_ext(l,el)
- | Array_type_eff_ext(teff_ext,i) ->
- Array_type_eff_ext(subst_type_ext t teff_ext, i)
- | Struct_type_eff_ext(l, fl) ->
- Struct_type_eff_ext(
- l, List.map (fun (id,(teff,copt)) -> (id,(subst_type_ext t teff,copt))) fl)
+ | Bool_type_eff -> Bool_type_eff
+ | Int_type_eff -> Int_type_eff
+ | Real_type_eff -> Real_type_eff
+ | External_type_eff l -> External_type_eff l
+ | Enum_type_eff(l,el) -> Enum_type_eff(l,el)
+ | Array_type_eff(teff_ext,i) ->
+ Array_type_eff(subst_type t teff_ext, i)
+ | Struct_type_eff(l, fl) ->
+ Struct_type_eff(
+ l, List.map (fun (id,(teff,copt)) -> (id,(subst_type t teff,copt))) fl)
| Any
| Overload -> t
(************************************************************************************)
(* Some unit tests *)
-let i = Int_type_eff_ext
-let r = Real_type_eff_ext
-let b = Bool_type_eff_ext
-let e = External_type_eff_ext (Ident.long_of_string "Toto::t")
+let i = Int_type_eff
+let r = Real_type_eff
+let b = Bool_type_eff
+let e = External_type_eff (Ident.long_of_string "Toto::t")
let o = Overload
let a = Any
-let array t c = Array_type_eff_ext(t,c)
-let struc t = Struct_type_eff_ext ((Ident.long_of_string "T::t"),
+let array t c = Array_type_eff(t,c)
+let struc t = Struct_type_eff ((Ident.long_of_string "T::t"),
[(Ident.of_string "x"),(t,None)])
let unify_failed = function Ko(_) -> true | _ -> false
@@ -130,10 +131,10 @@ let to_string = function
let proposition1 t1 t2 =
(* two lists of type are unifiable iff there exists a substitution
- that makes them equal. Hence, if [f] and [subst_type_ext] are
+ that makes them equal. Hence, if [f] and [subst_type] are
correct, the following function should always return true *)
match f t1 t2 with
- | Unif t -> List.map (subst_type_ext t) t1 = List.map (subst_type_ext t) t2
+ | Unif t -> List.map (subst_type t) t1 = List.map (subst_type t) t2
| _ -> true
(* Since i don't know how to prove proposition1, I generate some random tests *)
@@ -176,8 +177,8 @@ let unit_test () =
let (tl1, tl2) = gen_unifiable_typeff_of_size (1+ Random.int 10) in
print_string (
" ==> try Unify.proposition1 with lists " ^
- (CompiledDataDump.type_eff_ext_list_to_string tl1) ^ " and " ^
- (CompiledDataDump.type_eff_ext_list_to_string tl2) ^ "\n");
+ (CompiledDataDump.type_eff_list_to_string tl1) ^ " and " ^
+ (CompiledDataDump.type_eff_list_to_string tl2) ^ "\n");
assert (proposition1 tl1 tl2)
done
diff --git a/src/unify.mli b/src/unify.mli
index f88b4b879badd82f864a474e60fcb6b4e3ab9d02..7cd2e5c3ca04b88841e4e7fc8111faf9e82a8e4d 100644
--- a/src/unify.mli
+++ b/src/unify.mli
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 28/05/2008 (at 14:16) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/06/2008 (at 10:06) by Erwan Jahier> *)
(** This unify function is quite specific. It can only unify 2 lists
of types with at most one type variable (Any or Overload).
@@ -15,14 +15,14 @@
type t =
| Equal
- | Unif of CompiledData.type_eff_ext
+ | Unif of CompiledData.type_eff
| Ko of string (* a msg explaining why the unification failed *)
-val f : CompiledData.type_eff_ext list -> CompiledData.type_eff_ext list -> t
+val f : CompiledData.type_eff list -> CompiledData.type_eff list -> t
-(** [subst_type_ext t1 t2 substitutes [t1] in [t2] *)
-val subst_type_ext :
- CompiledData.type_eff_ext -> CompiledData.type_eff_ext -> CompiledData.type_eff_ext
+(** [subst_type t1 t2 substitutes [t1] in [t2] *)
+val subst_type :
+ CompiledData.type_eff -> CompiledData.type_eff -> CompiledData.type_eff
(**/**)