diff --git a/src/Makefile b/src/Makefile
index f9b4f22622318ad3d5d4a646abff7a9ac7db6c51..6651a14ad54991023b7721b7b70d326c48cc5d63 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -15,6 +15,7 @@ SOURCES = \
./lxm.mli \
./lxm.ml \
./errors.ml \
+ ./predef.ml \
./syntaxTreeCore.ml \
./syntaxTree.ml \
./parserUtils.ml \
@@ -31,6 +32,8 @@ SOURCES = \
./compiledData.ml \
./syntaxTab.mli \
./syntaxTab.ml \
+ ./predefSemantics.mli \
+ ./predefSemantics.ml \
./evalConst.mli \
./evalConst.ml \
./getEff.mli \
diff --git a/src/TODO b/src/TODO
index a9d5eb66aa72b9dec5db2600c4a27342567a6ae7..fb40d3195b3def2570bab92db0638b27ad867122 100644
--- a/src/TODO
+++ b/src/TODO
@@ -1,6 +1,9 @@
*** questions
+* est-ce que le package Lustre est utilisé par default ?
+pour l'instant, je fais comme si...
+
* instanciation de package <<locaux>> à d'autre package interdite
pour l'instant, alors que ca marchait chez Youssef.
@@ -34,14 +37,23 @@ le package principal est implicite. Autorise-t'on ce genre de m
* verifier que chacun des exemples du repertoire "should_fail" à une
correspondance dans le manuel, et reciproquement...
-* que fait-on des constantes réelle ?
+* Que fait-on des constantes réelles ?
+
par exemple, dans test/should_work/NONREG/simple.lus,
const right = pi/2.;
est evalué (+ warning) alors qu'on ne devrait pas je trouve.
+
-> à discuter
+par exemple, pour les comparaisons, c'est ok à la limite. mais pour
+les operateurs aritmetiques, bof.
+
+* pour l'evaluation statique de l'egalité, j'ai pas fait pareil...
+-> à discuter (cfpredefInfo.ml)
+
+
***********************************************************************************
*** a faire
diff --git a/src/compiledData.ml b/src/compiledData.ml
index 00a5fef969128c8648df86d573eed9e7e89f354c..15decbb441b4b29b387887695ffbb9aceb0e1a72 100644
--- a/src/compiledData.ml
+++ b/src/compiledData.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 14/03/2008 (at 15:21) by Erwan Jahier> *)
+(** Time-stamp: <modified the 19/03/2008 (at 16:20) by Erwan Jahier> *)
(**
@@ -174,51 +174,11 @@ and by_name_op_eff =
and by_pos_op_eff =
+ | Predef_eff of Predef.op
| CALL_eff of node_exp_eff srcflagged
- (* XXX quid des operateur predef ?
-
- J'ai envie de les virer de la et de les mettre dans la table
- des noeuds normaux via le fichier predef.
-
- J'ai juste un doute pour la gestion de la surcharge...
-
- bon, on verra plus tard.
- *)
| PRE_eff
-
- | ICONST_eff of Ident.t
- | RCONST_eff of Ident.t
| IDENT_eff of Ident.idref
-
- | TRUE_eff
- | FALSE_eff
- | NOT_eff
| CURRENT_eff
- | REAL2INT_eff
- | INT2REAL_eff
- | AND_eff
- | OR_eff
- | XOR_eff
- | IMPL_eff
- | EQ_eff
- | NEQ_eff
- | LT_eff
- | LTE_eff
- | GT_eff
- | GTE_eff
- | DIV_eff
- | MOD_eff
- | IF_eff
- | NOR_eff
- | DIESE_eff
-
- | UMINUS_eff
- | MINUS_eff
- | PLUS_eff
- | SLASH_eff
- | TIMES_eff
- | POWER_eff
-
| ARROW_eff
| FBY_eff
| WHEN_eff
diff --git a/src/evalConst.ml b/src/evalConst.ml
index d77a83d7a7cfe0467624f14ca81b13993e006d96..24a8e586f4de912c40b41632dec95a17c587c590 100644
--- a/src/evalConst.ml
+++ b/src/evalConst.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 17/03/2008 (at 14:29) by Erwan Jahier> *)
+(** Time-stamp: <modified the 20/03/2008 (at 10:03) by Erwan Jahier> *)
open Printf
@@ -7,6 +7,8 @@ open Errors
open SyntaxTree
open SyntaxTreeCore
open CompiledData
+open Predef
+open PredefSemantics
(*----------------------------------------------------
EvalArray_error :
@@ -16,315 +18,15 @@ exception EvalArray_error of string
(*----------------------------------------------------
EvalConst_error :
- - levée localement dans les sous-fonctions,
- - captée dans EvalConst.f et tranformée en Compile_error.
+ - levée localement dans les sous-fonctions,
+ - captée dans EvalConst.f et tranformée en Compile_error.
----------------------------------------------------*)
-exception EvalConst_error of string
-(*----------------------------------------------------
-Utilitaires : erreurs classiques
-----------------------------------------------------*)
-let type_error (v : const_eff list) (expect : string) =
- raise (EvalConst_error(sprintf "type combination error, %s expected" expect))
-
-(* Utile : erreur d'arité *)
-let arity_error (v : const_eff list) (expect : string) =
- raise (EvalConst_error(
- sprintf "arity error, %s instead of %d" expect (List.length v)))
-
-(* Utile : erreur, opérateur interdit *)
-let uneval_error (v : const_eff list) (opname : string) =
- raise (EvalConst_error(
- sprintf "operation %s not allowed in static expression" opname))
-
-(*----------------------------------------------------
- Calcul sur les const_eff
-------------------------------------------------------
-op_computer :
-- associe à chaque opérateur évaluable (posop : by_pos_op)
- une fonction de calcul Some (const_eff list -> const_eff_list)
- ou Erreur
-----------------------------------------------------*)
-
-let op_computer (posop : by_pos_op) (src: Lxm.t)
- = (* retour : (const_eff list -> const_eff_list) option *)
- (
- (*----------------------------
- le template pour tous les :
- bool*bool->bool
- ----------------------------*)
- let generic_bin_bool
- (nm : string)
- (f : bool -> bool -> bool)
- (args : const_eff list)
- = (
- match args with
- [Bool_const_eff v0; Bool_const_eff v1] -> [Bool_const_eff (f v0 v1)]
- | [x0; x1] -> (type_error [x0; x1] "bool*bool")
- | x -> (arity_error x "2" )
- ) in
- (*----------------------------
- le template pour tous les :
- int*int->int
- ----------------------------*)
- let generic_bin_int
- (nm : string)
- (f : int -> int -> int)
- (args : const_eff list)
- = (
- match args with
- [Int_const_eff v0; Int_const_eff v1] -> [Int_const_eff (f v0 v1)]
- | [x0; x1] -> (type_error [x0; x1] "int*int")
- | x -> (arity_error x "2" )
- ) in
- (*----------------------------
- le template pour tous les :
- num*num->bool
- N.B. on est obligé de passer
- 2 "copies" du comparateur
- (fi pour int, fr pour float)
- sinon caml ne peut pas typer ...
- ----------------------------*)
- let generic_num_comp
- (nm : string)
- (fi : int -> int -> bool)
- (fr : float -> float -> bool)
- (args : const_eff list)
- = (
- match args with
- [Int_const_eff v0; Int_const_eff v1] -> (
- [Bool_const_eff (fi v0 v1)]
- )
- | [Real_const_eff v0; Real_const_eff v1] -> (
- let res = (fr v0 v1) in
- warning src
- (sprintf
- "float in static exp: %f%s%f evaluated as %b" v0 nm v1 res);
- [Bool_const_eff res]
- )
- | [x0; x1] -> (type_error [x0; x1] "int*int or real*real")
- | x -> (arity_error x "2" )
- ) in
- (*----------------------------
- le template pour tous les :
- num*num->num
- ----------------------------*)
- let generic_bin_num
- (nm : string)
- (fi : int -> int -> int)
- (fr : float -> float -> float)
- (args : const_eff list)
- = (
- match args with
- [Int_const_eff v0; Int_const_eff v1] ->
- [Int_const_eff (fi v0 v1)]
-
- | [Real_const_eff v0; Real_const_eff v1] -> (
- let res = (fr v0 v1) in
- warning src
- (sprintf
- "float in static exp: %f%s%f evaluated as %f" v0 nm v1 res);
- [Real_const_eff res]
- )
- | [x0; x1] -> (type_error [x0; x1] "int*int or real*real")
- | x -> (arity_error x "2" )
- ) in
- (*----------------------------
- Calcul du if
- ----------------------------*)
- let compute_if (args : const_eff list) = (
- match args with
- [Bool_const_eff c; x1; x2] -> (
- let t1 = type_of_const_eff x1 in
- let t2 = type_of_const_eff x2 in
- if (t1 = t2 ) then (if (c) then [x1] else [x2])
- else (type_error args "bool*t*t for some type t")
- )
- | [x0; x1; x2] -> (type_error args "bool*t*t for some type t")
- | x -> (arity_error x "3")
- )
- in
- (*----------------------------
- 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
-
- | [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
- (* match principal *)
- match posop with
- TRUE_n -> (
- function
- [] -> [ Bool_const_eff true ]
- | x -> arity_error x "0"
- )
- | FALSE_n -> (
- function
- [] -> [ Bool_const_eff false ]
- | x -> arity_error x "0"
- )
- | ICONST_n s -> (
- function
- [] -> [ Int_const_eff (int_of_string (Ident.to_string s)) ]
- | x -> arity_error x "0"
- )
- | RCONST_n s -> (
- function
- [] -> [ Real_const_eff (float_of_string (Ident.to_string s)) ]
- | x -> arity_error x "0"
- )
- | IDENT_n s -> assert false
- (* unaires *)
- | NOT_n -> (
- function
- [Bool_const_eff v] -> [Bool_const_eff (not v)]
- | [x] -> type_error [x] "bool"
- | x -> arity_error x "1"
- )
- | UMINUS_n -> (
- function
- [Int_const_eff v] -> [Int_const_eff (- v)]
- | [Real_const_eff v] -> [Real_const_eff (-. v)]
- | [x] -> type_error [x] "int or real"
- | x -> arity_error x "1"
- )
- | PRE_n -> ( function x -> uneval_error x "pre")
- | CURRENT_n -> ( function x -> uneval_error x "current")
- | REAL2INT_n -> (
- function
- [Real_const_eff v] -> (
- let res = (int_of_float v) in
- warning src
- (sprintf "float2int cast: '%f' converted to '%d'" v res);
- [Int_const_eff res]
- )
- | [x] -> type_error [x] "real"
- | x -> arity_error x "1"
- )
- | INT2REAL_n -> (
- function
- [Int_const_eff v] -> [Real_const_eff (float_of_int v)]
- | [x] -> type_error [x] "int"
- | x -> arity_error x "1"
- )
- (* binaires *)
- | ARROW_n -> ( function x -> uneval_error x "->")
- | WHEN_n -> (
- function x -> uneval_error x "when"
- )
- (* pour les operateurs binaire booléens, on a un seul "template" *)
- | AND_n -> ( generic_bin_bool "and" (&&) )
- | OR_n -> ( generic_bin_bool "or" (or) )
- | XOR_n -> ( generic_bin_bool "xor" (<>) )
- | IMPL_n -> ( generic_bin_bool "=>" (function x -> function y -> not x or y))
- | EQ_n -> ( compute_eq )
- | NEQ_n -> (
- function x -> (
- match (compute_eq x) with
- [Bool_const_eff v] -> [Bool_const_eff (not v)]
- | x -> x
- )
- )
- | LT_n -> ( generic_num_comp "<" (<) (<) )
- | LTE_n -> ( generic_num_comp "<=" (<=) (<=) )
- | GT_n -> ( generic_num_comp ">" (>) (>) )
- | GTE_n -> ( generic_num_comp ">=" (>=) (>=) )
- | DIV_n -> ( generic_bin_int "div" ( / ) )
- | MOD_n -> ( generic_bin_int "mod" ( mod ) )
- | MINUS_n -> ( generic_bin_num "-" (-) (-.) )
- | PLUS_n -> ( generic_bin_num "+" (+) (+.) )
- | SLASH_n -> ( generic_bin_num "/" (/) (/.) )
- | TIMES_n -> ( generic_bin_num "*" ( * ) ( *. ) )
- | POWER_n -> assert false
- (* ternaires *)
- | IF_n -> (compute_if)
- (* n-aires *)
- | NOR_n -> assert false
- | DIESE_n -> assert false
- | CALL_n s -> assert false
- (* pseudo-unaire : acces structure *)
- | STRUCT_ACCESS_n fid -> (
- function
- [Struct_const_eff (flst, typ)] -> (
- try [(List.assoc (fid) flst)]
- with Not_found ->
- raise (
- EvalConst_error
- (sprintf
- "%s is not a field of struct %s"
- (Ident.to_string fid) (string_of_type_eff(typ))
- ))
- )
- | [x] -> type_error [x] "struct type"
- | x -> arity_error x "1"
- )
- | ITERATOR_n _ -> assert false
- | MERGE_n _ -> assert false
- | ARRAY_SLICE_n _ -> assert false
- | ARRAY_ACCES_n _ -> assert false
- | ARRAY_n -> assert false
- | TUPLE_n -> assert false
- | WITH_n -> assert false
- | CONCAT_n -> assert false
- | HAT_n -> assert false
- | FBY_n -> assert false
- )
+
+let not_evaluable_construct str =
+ raise (EvalConst_error(
+ Printf.sprintf "The construct %s is not allowed in static expression"
+ str))
(*----------------------------------------------------
Utilitaire :
@@ -336,19 +38,19 @@ venir de eva et donc
N.B. Puisque correct, last_ix est inutile, mais bon ...
-----------------------------------------------------*)
let make_slice_const
- (ctab : const_eff array)
- (ctype : type_eff)
- (slice : slice_info_eff)
-= (
- let get_res (ix : int) = (
- Array.get ctab (slice.se_first + ix*slice.se_step)
- ) in
+ (ctab : const_eff array)
+ (ctype : type_eff)
+ (slice : slice_info_eff)
+ = (
+ let get_res (ix : int) = (
+ Array.get ctab (slice.se_first + ix*slice.se_step)
+ ) in
[Array_const_eff (Array.init slice.se_width get_res, ctype)]
-)
+ )
(*----------------------------------------------------
-Utilitaire : fabriquer si possible une const tableau
------------------------------------------------------*)
+ Utilitaire : fabriquer si possible une const tableau
+ -----------------------------------------------------*)
let make_array_const (ops : const_eff list array) = (
let expected_type = ref None in
let treat_arg (op : const_eff list) = (
@@ -383,10 +85,10 @@ let make_array_const (ops : const_eff list array) = (
None -> raise (EvalConst_error("empty array"))
| Some t -> Array_const_eff(res, t)
)
-(*----------------------------------------------------
-Utilitaire : fabriquer si possible une cons structure
+(**
+Utilitaire : fabriquer si possible une constante structure
N.B. Par construction on sait que nops n'a pas de doublons
------------------------------------------------------*)
+*)
let make_struct_const
(teff : type_eff)
(arg_tab : (Ident.t, Lxm.t * const_eff) Hashtbl.t) =
@@ -472,8 +174,11 @@ let rec f
match vexp with
CallByPos ({it=posop; src=lxm}, Oper args) -> (
try eval_by_pos_const posop lxm args
- with EvalConst_error msg ->
- raise (Compile_error(lxm, "can't eval constant: "^msg))
+ with
+ | EvalType_error msg ->
+ raise (Compile_error(lxm, "type error: "^msg))
+ | EvalConst_error msg ->
+ raise (Compile_error(lxm, "can't eval constant: "^msg))
)
| CallByName ({it=nmop; src=lxm}, nmargs ) -> (
try eval_by_name_const nmop lxm nmargs
@@ -513,7 +218,7 @@ let rec f
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 x "bool"
+ | x -> type_error_const x "bool"
)
| _ -> raise (EvalConst_error(
sprintf
@@ -590,17 +295,16 @@ let rec f
)
with EvalArray_error msg -> raise(EvalConst_error msg)
) |
- _ -> type_error effargs "some array"
+ _ -> type_error_const effargs "some array"
) |
- _ -> type_error effargs "some array"
+ _ -> type_error_const effargs "some array"
)
| ARRAY_SLICE_n sl -> (
- (* évalue l'argument *)
let (elts, typelts) = (
match List.flatten (List.map rec_eval_const args) with
[Array_const_eff (l, t)] -> (l, t)
- | x -> type_error x "some array"
+ | x -> type_error_const x "some array"
) in
(* on en déduit la taille du tableau *)
let sz = Array.length elts in
@@ -610,23 +314,36 @@ let rec f
make_slice_const elts typelts sliceff
) with
EvalArray_error msg -> raise(EvalConst_error msg)
- ) |
- (* extension homomorphe spéciale ? *)
- CALL_n s -> (
- print_string "*** node call not yet implemented\n";
- assert false
- )
- |
- (* PAS D'EXTENTION HOMOMORPHE IMPLICITE
-
- Toutes les autres opérations sont des
- cas classiques d'extention homomorphe *)
- _ ->
- (
- let effargs = List.flatten (List.map rec_eval_const args) in
- (* compute_homomorphic_op (op_computer posop lxm) effargs *)
- (op_computer posop lxm) effargs
- )
+ )
+
+ | 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) (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"
+
+ | ITERATOR_n _ -> not_evaluable_construct "iterator"
+ | Predef op
+ ->
+ let effargs = List.flatten (List.map rec_eval_const args) in
+ (PredefSemantics.const_eval op) effargs
+
) (* FIN DE : eval_by_pos_const *)
(*-------------------------------------*)
(* Fonction récursive secondaire *)
diff --git a/src/expandPack.ml b/src/expandPack.ml
index 05d52074d3f83588090eb07e6a5093b6b4f48709..4d0408d6953bdc12babf4770a87a5ff18b988951 100644
--- a/src/expandPack.ml
+++ b/src/expandPack.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 11/03/2008 (at 15:48) by Erwan Jahier> *)
+(** Time-stamp: <modified the 20/03/2008 (at 11:36) by Erwan Jahier> *)
open Lxm
open SyntaxTree
@@ -68,7 +68,7 @@ let (doit:
| StaticParamConst (s,te) -> (
let ce = match (a.it) with
| StaticArgIdent idr ->
- SyntaxTreeCore.leafexp a.src (IDENT_n idr)
+ ParserUtils.leafexp a.src (IDENT_n idr)
| StaticArgConst x -> x
| _ -> instance_error ()
in
diff --git a/src/getEff.ml b/src/getEff.ml
index 27d208b72d04e6b7138d6f23f36a07701460d824..07b0f162f8fb4cafbda683ba98d5397892d029ba 100644
--- a/src/getEff.ml
+++ b/src/getEff.ml
@@ -1,7 +1,8 @@
-(** Time-stamp: <modified the 17/03/2008 (at 14:10) by Erwan Jahier> *)
+(** Time-stamp: <modified the 19/03/2008 (at 16:20) by Erwan Jahier> *)
open Lxm
+open Predef
open SyntaxTree
open SyntaxTreeCore
open CompiledData
@@ -10,23 +11,6 @@ open Errors
let finish_me msg = print_string (
"\n\tXXX getEff.ml:\n\tXXX "^msg^" -> finish me!\n")
-
-let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
- static_param srcflagged list) =
- fun symbols lxm idref ->
- match SymbolTab.find_node symbols (Ident.name_of_idref idref) lxm with
- | SymbolTab.Here ni -> (
- match ni.it.static_params with
- | None -> [] (* should I raise en error here? *)
- | Some sp -> sp
- )
- | SymbolTab.NotHere imported_node ->
- finish_me ((Lxm.details lxm) ^
- ": imported node "^(Ident.string_of_long imported_node)^
- " in static args");
- assert false
-
-
(******************************************************************************)
exception GetEffType_error of string
@@ -54,6 +38,21 @@ let rec (typ:CompiledData.id_solver -> SyntaxTreeCore.type_exp ->
(******************************************************************************)
+let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
+ static_param srcflagged list) =
+ fun symbols lxm idref ->
+ match SymbolTab.find_node symbols (Ident.name_of_idref idref) lxm with
+ | SymbolTab.Here ni -> (
+ match ni.it.static_params with
+ | None -> [] (* should I raise en error here? *)
+ | Some sp -> sp
+ )
+ | SymbolTab.NotHere imported_node ->
+ finish_me ((Lxm.details lxm) ^
+ ": imported node "^(Ident.string_of_long imported_node)^
+ " in static args");
+ assert false
+
(* exported *)
let rec (node : CompiledData.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
CompiledData.node_exp_eff) =
@@ -206,47 +205,13 @@ and translate_by_name_op = function
and translate_field id_solver (id, ve) = (id, translate_val_exp id_solver ve)
and (translate_by_pos_op : id_solver -> by_pos_op -> Lxm.t -> by_pos_op_eff) =
- fun id_solver by_pos_op lxm ->
+ fun id_solver by_pos_op lxm ->
match by_pos_op with
- (* zeroaire *)
- | ICONST_n id -> ICONST_eff id
- | RCONST_n id -> RCONST_eff id
- | IDENT_n idref -> IDENT_eff idref
-
- | TRUE_n -> TRUE_eff
- | FALSE_n -> FALSE_eff
- | NOT_n -> NOT_eff
+ | Predef op -> Predef_eff op
+ | IDENT_n idref -> IDENT_eff idref
| CURRENT_n -> CURRENT_eff
- | REAL2INT_n -> REAL2INT_eff
- | INT2REAL_n -> INT2REAL_eff
- | AND_n -> AND_eff
- | OR_n -> OR_eff
- | XOR_n -> XOR_eff
- | IMPL_n -> IMPL_eff
- | EQ_n -> EQ_eff
- | NEQ_n -> NEQ_eff
- | LT_n -> LT_eff
- | LTE_n -> LTE_eff
- | GT_n -> GT_eff
- | GTE_n -> GTE_eff
- | DIV_n -> DIV_eff
- | MOD_n -> MOD_eff
- | IF_n -> IF_eff
- | NOR_n -> NOR_eff
- | DIESE_n -> DIESE_eff
-
-
- (* overloaded operator *)
- | UMINUS_n -> UMINUS_eff
- | MINUS_n -> MINUS_eff
- | PLUS_n -> PLUS_eff
- | SLASH_n -> SLASH_eff
- | TIMES_n -> TIMES_eff
- | POWER_n -> POWER_eff
-
| PRE_n -> PRE_eff
-
- | CALL_n node_exp_f ->
+ | CALL_n node_exp_f ->
CALL_eff (flagit (node id_solver node_exp_f) node_exp_f.src)
| ARROW_n -> ARROW_eff
diff --git a/src/getEff.mli b/src/getEff.mli
index 9e30aca03e3a460b0aa454f464568616e08ab677..2c396b3e41398cc6c222b666a4bc80b98c32327b 100644
--- a/src/getEff.mli
+++ b/src/getEff.mli
@@ -1,14 +1,19 @@
-(** Time-stamp: <modified the 17/03/2008 (at 14:10) by Erwan Jahier> *)
+(** Time-stamp: <modified the 17/03/2008 (at 15:49) by Erwan Jahier> *)
+
+
+(** *)
+
+(** Calls [EvalConst] *)
+val typ : CompiledData.id_solver -> SyntaxTreeCore.type_exp -> CompiledData.type_eff
(**
A [node_exp] is a name plus a list of static arguments.
- The goal of [f] is to
+ The goal of [node] is to
- compute the effective type of static arguments
- - check they are comptible with the node signature
+ - check they are compatible with the node signature
check the type of the static arguments (
*)
-
val node : CompiledData.id_solver -> SyntaxTreeCore.node_exp Lxm.srcflagged ->
CompiledData.node_exp_eff
@@ -19,4 +24,3 @@ val val_exp : CompiledData.id_solver -> SyntaxTreeCore.val_exp Lxm.srcflagged -
CompiledData.val_exp_eff Lxm.srcflagged
-val typ : CompiledData.id_solver -> SyntaxTreeCore.type_exp -> CompiledData.type_eff
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index ed45560f938b10581f7cff4c63d52c01da11a712..6659d80587a10ff4ea5627927d53e5b7aea214e1 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 17/03/2008 (at 14:56) by Erwan Jahier> *)
+(** Time-stamp: <modified the 17/03/2008 (at 15:14) by Erwan Jahier> *)
open Lxm
@@ -120,12 +120,12 @@ fun tbl ->
o tabulates its result
o takes an x_key and returns an [x_eff]
o lookups its (syntaxic) definition (x_info) via the symbolTab.t
- o calls evalX.f to translate its sub-terms
+ o calls [GetEff.X] to translate its sub-terms
- [GetEff.X]
o takes a [x_exp] (i.e., an expression) and returns an [x_eff]
o compute the effective static args (for nodes)
- o calls solve_x_idref (via [id_solver]) to translate its sub-terms
+ o calls [solve_x_idref] (via [id_solver]) to translate its sub-terms
- [solve_x_idref]
@@ -135,7 +135,7 @@ fun tbl ->
nb2: the top-level call is [node_check], on a node that necessarily contains
- no static parameters. Then:
+ no static parameters.
*)
diff --git a/src/parser.mly b/src/parser.mly
index b5514ff0e1788eb8817fe0e907a2f0f49e0859a1..40e2e895586f86165d6d1fd0a0a4753ee8a8ae06 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -1,5 +1,6 @@
%{
open Lxm
+open Predef
open SyntaxTree
open SyntaxTreeCore
open ParserUtils
@@ -1027,44 +1028,44 @@ sxExpression:
sxConstant { $1 }
| sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
/* unaires */
- | TK_NOT sxExpression { unexp $1 NOT_n $2 }
+ | TK_NOT sxExpression { unexp_predef $1 NOT_n $2 }
| TK_MINUS sxExpression %prec TK_UMINUS
- { unexp $1 UMINUS_n $2 }
+ { 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 $1 REAL2INT_n $2 }
- | TK_REAL sxExpression { unexp $1 INT2REAL_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 $2 AND_n $1 $3 }
- | sxExpression TK_OR sxExpression { binexp $2 OR_n $1 $3 }
- | sxExpression TK_XOR sxExpression { binexp $2 XOR_n $1 $3 }
- | sxExpression TK_IMPL sxExpression { binexp $2 IMPL_n $1 $3 }
- | sxExpression TK_EQ sxExpression { binexp $2 EQ_n $1 $3 }
- | sxExpression TK_NEQ sxExpression { binexp $2 NEQ_n $1 $3 }
- | sxExpression TK_LT sxExpression { binexp $2 LT_n $1 $3 }
- | sxExpression TK_LTE sxExpression { binexp $2 LTE_n $1 $3 }
- | sxExpression TK_GT sxExpression { binexp $2 GT_n $1 $3 }
- | sxExpression TK_GTE sxExpression { binexp $2 GTE_n $1 $3 }
- | sxExpression TK_DIV sxExpression { binexp $2 DIV_n $1 $3 }
- | sxExpression TK_MOD sxExpression { binexp $2 MOD_n $1 $3 }
- | sxExpression TK_MINUS sxExpression { binexp $2 MINUS_n $1 $3 }
- | sxExpression TK_PLUS sxExpression { binexp $2 PLUS_n $1 $3 }
- | sxExpression TK_SLASH sxExpression { binexp $2 SLASH_n $1 $3 }
- | sxExpression TK_STAR sxExpression { binexp $2 TIMES_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 $1 IF_n $2 $4 $6 }
+ { ternexp_predef $1 IF_n $2 $4 $6 }
| TK_WITH sxExpression TK_THEN sxExpression TK_ELSE sxExpression
{ ternexp $1 WITH_n $2 $4 $6 }
/* n-aires */
/* WARNING ! il faut remettre la liste à l'endroit */
| TK_DIESE TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
- { naryexp $1 DIESE_n (List.rev $3) }
+ { naryexp_predef $1 DIESE_n (List.rev $3) }
| TK_NOR TK_OPEN_PAR sxExpressionList TK_CLOSE_PAR
- { naryexp $1 NOR_n (List.rev $3) }
+ { naryexp_predef $1 NOR_n (List.rev $3) }
| sxCallByPosExpression
{ $1 }
| TK_OPEN_PAR sxExpList2 TK_CLOSE_PAR
@@ -1095,30 +1096,30 @@ sxExpression:
;
sxPredefOp:
- | TK_NOT { {src=$1; it=NOT_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=AND_n } }
- | TK_OR { {src=$1; it=OR_n } }
- | TK_XOR { {src=$1; it=XOR_n } }
- | TK_IMPL { {src=$1; it=IMPL_n } }
- | TK_EQ { {src=$1; it=EQ_n } }
- | TK_NEQ { {src=$1; it=NEQ_n } }
- | TK_LT { {src=$1; it=LT_n } }
- | TK_LTE { {src=$1; it=LTE_n } }
- | TK_GT { {src=$1; it=GT_n } }
- | TK_GTE { {src=$1; it=GTE_n } }
- | TK_DIV { {src=$1; it=DIV_n } }
- | TK_MOD { {src=$1; it=MOD_n } }
- | TK_MINUS { {src=$1; it=MINUS_n } }
- | TK_PLUS { {src=$1; it=PLUS_n } }
- | TK_SLASH { {src=$1; it=SLASH_n } }
- | TK_STAR { {src=$1; it=TIMES_n } }
- | TK_POWER { {src=$1; it=POWER_n } }
- | TK_IF { {src=$1; it=IF_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_POWER { {src=$1; it=Predef(POWER_n) } }
+ | TK_IF { {src=$1; it=Predef(IF_n) } }
;
/* Appel fonctionnel par position (classique) */
/* NB
@@ -1126,10 +1127,10 @@ sxPredefOp:
*/
sxCallByPosExpression:
sxEffectiveNode TK_OPEN_PAR sxExpression TK_CLOSE_PAR
- { naryexp $1.src (CALL_n $1) [$3] }
+ { naryexp $1.src (call_or_predef $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) }
+ { naryexp $1.src (call_or_predef $1) (List.rev $3) }
;
/* Effective node : une constrcution qui designe un noeud */
@@ -1222,27 +1223,27 @@ sxSimpleExp:
sxConstant { $1 }
| sxIdentRef { leafexp $1.src (IDENT_n $1.it) }
| TK_OPEN_PAR sxSimpleExp TK_CLOSE_PAR { $2 }
- | TK_NOT sxSimpleExp { unexp $1 NOT_n $2 }
- | TK_MINUS sxSimpleExp %prec TK_UMINUS { unexp $1 UMINUS_n $2 }
- | sxSimpleExp TK_AND sxSimpleExp { binexp $2 AND_n $1 $3 }
- | sxSimpleExp TK_OR sxSimpleExp { binexp $2 OR_n $1 $3 }
- | sxSimpleExp TK_XOR sxSimpleExp { binexp $2 XOR_n $1 $3 }
- | sxSimpleExp TK_IMPL sxSimpleExp { binexp $2 IMPL_n $1 $3 }
- | sxSimpleExp TK_EQ sxSimpleExp { binexp $2 EQ_n $1 $3 }
- | sxSimpleExp TK_NEQ sxSimpleExp { binexp $2 NEQ_n $1 $3 }
- | sxSimpleExp TK_LT sxSimpleExp { binexp $2 LT_n $1 $3 }
- | sxSimpleExp TK_LTE sxSimpleExp { binexp $2 LTE_n $1 $3 }
- | sxSimpleExp TK_GT sxSimpleExp { binexp $2 GT_n $1 $3 }
- | sxSimpleExp TK_GTE sxSimpleExp { binexp $2 GTE_n $1 $3 }
- | sxSimpleExp TK_DIV sxSimpleExp { binexp $2 DIV_n $1 $3 }
- | sxSimpleExp TK_MOD sxSimpleExp { binexp $2 MOD_n $1 $3 }
- | sxSimpleExp TK_MINUS sxSimpleExp { binexp $2 MINUS_n $1 $3 }
- | sxSimpleExp TK_PLUS sxSimpleExp { binexp $2 PLUS_n $1 $3 }
- | sxSimpleExp TK_SLASH sxSimpleExp { binexp $2 SLASH_n $1 $3 }
- | sxSimpleExp TK_STAR sxSimpleExp { binexp $2 TIMES_n $1 $3 }
+ | 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 $1 IF_n $2 $4 $6 }
+ { ternexp_predef $1 IF_n $2 $4 $6 }
;
/* Appel fonctionnel par nom */
@@ -1292,13 +1293,13 @@ sxExpressionList: sxExpression
;
sxConstant: TK_TRUE
- { (leafexp $1 TRUE_n) }
+ { (leafexp $1 (Predef TRUE_n)) }
| TK_FALSE
- { (leafexp $1 FALSE_n) }
+ { (leafexp $1 (Predef FALSE_n)) }
| TK_ICONST
- { (leafexp $1 (ICONST_n (Lxm.id $1))) }
+ { (leafexp $1 (Predef(ICONST_n (Lxm.id $1)))) }
| TK_RCONST
- { (leafexp $1 (RCONST_n (Lxm.id $1))) }
+ { (leafexp $1 (Predef(RCONST_n (Lxm.id $1)))) }
;
/* WARNING ! : les listes sont crées à l'envers */
diff --git a/src/parserUtils.ml b/src/parserUtils.ml
index d4f597eb2b02769b3f4266918f892490ae78070f..35cef33975cdb62dfab8b40513e8824622a154ae 100644
--- a/src/parserUtils.ml
+++ b/src/parserUtils.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 10/03/2008 (at 17:35) by Erwan Jahier> *)
+(** Time-stamp: <modified the 20/03/2008 (at 11:35) by Erwan Jahier> *)
@@ -115,3 +115,37 @@ let flat_twice_flagged_list
List.fold_left g [] inlist
)
+(**********************************************************************************)
+
+(** Utilitaries to build [val_exp] *)
+
+let leafexp lxm op = CallByPos({src = lxm ; it = op }, Oper [])
+
+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] )
+
+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] )
+
+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 )
+
+
+let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )
+
+open Ident
+
+(* used in the parser to recognize if a node is a predefined operators *)
+let (call_or_predef : node_exp Lxm.srcflagged -> by_pos_op) =
+ fun nef ->
+ let {it=(idref, sargs); src=lxm } = nef in
+ match idref.id_pack with
+ | None (* We consider that the Lustre package is used by default *)
+ | Some "Lustre" -> (
+ try Predef (Predef.string_to_op idref.id_id)
+ with Not_found -> CALL_n nef
+ )
+ | Some _ -> CALL_n nef
diff --git a/src/predef.ml b/src/predef.ml
new file mode 100644
index 0000000000000000000000000000000000000000..226b13750d27fec95bcf6ed8cee831fff8707ec7
--- /dev/null
+++ b/src/predef.ml
@@ -0,0 +1,165 @@
+(** Time-stamp: <modified the 20/03/2008 (at 11:48) by Erwan Jahier> *)
+
+
+
+type op =
+(* zero-ary *)
+ | TRUE_n
+ | FALSE_n
+ | ICONST_n of Ident.t
+ | RCONST_n of Ident.t
+(* unary *)
+ | NOT_n
+ | REAL2INT_n
+ | INT2REAL_n
+(* binary *)
+ | AND_n
+ | OR_n
+ | XOR_n
+ | IMPL_n
+ | EQ_n
+ | NEQ_n
+ | LT_n
+ | LTE_n
+ | GT_n
+ | GTE_n
+ | DIV_n
+ | MOD_n
+(* ternary *)
+ | IF_n
+(* n-ary *)
+ | NOR_n
+ | DIESE_n
+
+(* overloaded operator *)
+ | UMINUS_n
+ | MINUS_n
+ | PLUS_n
+ | SLASH_n
+ | TIMES_n
+ | POWER_n
+
+(* un-overloaded operator *)
+ | IUMINUS_n
+ | IMINUS_n
+ | IPLUS_n
+ | ISLASH_n
+ | ITIMES_n
+ | IPOWER_n
+
+ | RUMINUS_n
+ | RMINUS_n
+ | RPLUS_n
+ | RSLASH_n
+ | RTIMES_n
+ | RPOWER_n
+
+let op2string = function
+ | TRUE_n -> "true"
+ | FALSE_n -> "false"
+ | ICONST_n id -> Ident.to_string id
+ | RCONST_n id -> Ident.to_string id
+ | NOT_n -> "not"
+ | REAL2INT_n -> "real2int"
+ | INT2REAL_n -> "int2real"
+ | AND_n -> "and"
+ | OR_n -> "or"
+ | XOR_n -> "xor"
+ | IMPL_n -> "=>"
+ | EQ_n -> "="
+ | NEQ_n -> "<>"
+ | LT_n -> "<"
+ | LTE_n -> "<="
+ | GT_n -> ">"
+ | GTE_n -> ">="
+ | DIV_n -> "div"
+ | MOD_n -> "mod"
+ | IF_n -> "if"
+ | NOR_n -> "nor"
+ | DIESE_n -> "#"
+ | UMINUS_n -> "-"
+ | MINUS_n -> "-"
+ | PLUS_n -> "+"
+ | SLASH_n -> "/"
+ | TIMES_n -> "*"
+ | POWER_n -> "^"
+ | IUMINUS_n -> "-"
+ | IMINUS_n -> "-"
+ | IPLUS_n -> "+"
+ | ISLASH_n -> "/"
+ | ITIMES_n -> "*"
+ | IPOWER_n -> "^"
+ | RUMINUS_n -> "-"
+ | RMINUS_n -> "-"
+ | RPLUS_n -> "+"
+ | RSLASH_n -> "/"
+ | RTIMES_n -> "*"
+ | RPOWER_n -> "^"
+
+
+
+(*********************************************************************************)
+(* We associate to each predefined infix operator a prefixed form
+ that is supposed to be prefixed by "Lustre::" in the source.
+
+ We do it also for operators that are already prefix (e.g., "not")
+ for the sake of homogeneity.
+*)
+
+
+let (string_to_op : string -> op) = function
+
+ (* zero-ary *)
+ | "true" -> TRUE_n
+ | "false" -> FALSE_n
+ (* unary *)
+ | "not" -> NOT_n
+ | "real2int" -> REAL2INT_n
+ | "int2real" -> INT2REAL_n
+ (* binary *)
+ | "and" -> AND_n
+ | "or" -> OR_n
+ | "xor" -> XOR_n
+ | "impl" -> IMPL_n
+ | "eq" -> EQ_n
+ | "neq" -> NEQ_n
+ | "lt" -> LT_n
+ | "lte" -> LTE_n
+ | "gt" -> GT_n
+ | "gte" -> GTE_n
+ | "div" -> DIV_n
+ | "mod" -> MOD_n
+ (* ternary *)
+ | "if" -> IF_n
+ (* n-ary *)
+ | "nor" -> NOR_n
+ | "diese" -> DIESE_n (* XXX should i put "#" instead ??? *)
+
+ (* overloaded operator *)
+ | "uminus" -> UMINUS_n
+ | "minus" -> MINUS_n
+ | "plus" -> PLUS_n
+ | "slash" -> SLASH_n
+ | "times" -> TIMES_n
+ | "power" -> POWER_n
+
+ (* un-overloaded operator *)
+ | "iuminus" -> IUMINUS_n
+ | "iminus" -> IMINUS_n
+ | "iplus" -> IPLUS_n
+ | "islash" -> ISLASH_n
+ | "itimes" -> ITIMES_n
+ | "ipower" -> IPOWER_n
+
+ | "ruminus" -> RUMINUS_n
+ | "rminus" -> RMINUS_n
+ | "rplus" -> RPLUS_n
+ | "rslash" -> RSLASH_n
+ | "rtimes" -> RTIMES_n
+ | "rpower" -> RPOWER_n
+ | _ -> raise Not_found
+
+
+(*********************************************************************************)
+
+
diff --git a/src/predefSemantics.ml b/src/predefSemantics.ml
new file mode 100644
index 0000000000000000000000000000000000000000..43e14170253027378eb64f0708cee2371b29078c
--- /dev/null
+++ b/src/predefSemantics.ml
@@ -0,0 +1,454 @@
+(** Time-stamp: <modified the 20/03/2008 (at 10:40) by Erwan Jahier> *)
+
+
+open Predef
+open SyntaxTreeCore
+open CompiledData
+
+
+(* exported *)
+type 'a evaluator = 'a list -> 'a list
+type typer = type_eff evaluator
+type const_evaluator = const_eff evaluator
+type clocker = clock_eff evaluator
+
+
+(*********************************************************************************)
+exception EvalConst_error of string
+exception EvalType_error of string
+
+let (type_error : type_eff list -> string -> 'a) =
+ fun v expect ->
+ raise (EvalType_error(
+ "type mismatch"^(if expect = "" then "" else (expect^" expected"))))
+
+let arity_error (v : type_eff list) (expect : string) =
+ raise (EvalType_error(
+ Printf.sprintf "arity error, %s instead of %d" expect (List.length v)))
+
+
+let (type_error_const : const_eff list -> string -> 'a) =
+ fun v expect ->
+ raise (EvalConst_error(
+ "type mismatch"^(if expect = "" then "" else (expect^" expected"))))
+
+let arity_error_const (v : const_eff list) (expect : string) =
+ raise (EvalConst_error(
+ Printf.sprintf "arity error, %s instead of %d" expect (List.length v)))
+
+let not_evaluable op l =
+ raise (EvalConst_error(
+ Printf.sprintf "The operator %s is not allowed in static expression"
+ (op2string op)))
+
+
+(*********************************************************************************)
+(**
+ Naming rules. In the following function names,
+ "a" stands for "any" or alpha (i.e., polymorph types)
+ "b" stands for "bool"
+ "i" stands for "int"
+ "f" stands for "float"
+ "o" stands for "overloaded", i.e., "int" ot "float"
+ "s" stands for string
+
+ Hence, for example, "iib" stands for "int -> int -> bool"
+*)
+let (bbb_typer:typer) = function
+ | [Bool_type_eff; Bool_type_eff] -> [Bool_type_eff]
+ | [x0; x1] -> type_error [x0; x1] "bool*bool"
+ | x -> arity_error x "2"
+
+let (ooo_typer:typer) = function
+ | [Int_type_eff; Int_type_eff] -> [Int_type_eff]
+ | [Real_type_eff; Real_type_eff] -> [Real_type_eff]
+ | [x0; x1] -> type_error [x0; x1] "int*int or real*real"
+ | x -> arity_error x "2"
+
+let (iii_typer: typer) = function
+ | [Int_type_eff; Int_type_eff] -> [Int_type_eff]
+ | [x0; x1] -> (type_error [x0; x1] "int*int")
+ | x -> (arity_error x "2")
+
+let (aab_typer: typer) = function
+ | [v0; v1] -> if v0 = v1 then [Bool_type_eff] else (type_error [v0; v1] "")
+ | x -> (arity_error x "2")
+
+let (fff_typer: typer) = function
+ | [Real_type_eff; Real_type_eff] -> [Real_type_eff]
+ | [x0;x1] -> (type_error [x0; x1] "real*real")
+ | x -> (arity_error x "2")
+
+let (bb_typer: typer) = function
+ | [Bool_type_eff] -> [Bool_type_eff]
+ | [x1] -> (type_error [x1] "bool")
+ | x -> (arity_error x "1")
+
+let (ii_typer: typer) = function
+ | [Int_type_eff] -> [Int_type_eff]
+ | [x1] -> (type_error [x1] "int")
+ | x -> (arity_error x "1")
+
+let (ff_typer: typer) = function
+ | [Real_type_eff] -> [Real_type_eff]
+ | [x1] -> (type_error [x1] "real")
+ | x -> (arity_error x "1")
+
+let (oo_typer: typer) = function
+ | [Int_type_eff] -> [Int_type_eff]
+ | [Real_type_eff] -> [Real_type_eff]
+ | [x0] -> type_error [x0] "int or real"
+ | x -> arity_error x "1"
+
+let (sf_typer: Ident.t -> typer) =
+ fun id ceff_list ->
+ try let _ = float_of_string (Ident.to_string id) in
+ (match ceff_list with
+ | [] -> [Real_type_eff]
+ | x -> (arity_error x "0") )
+ with Failure "float_of_string" ->
+ raise (EvalType_error(
+ Printf.sprintf "Error when conterting %s into a float"
+ (Ident.to_string id)))
+
+let (si_typer: Ident.t -> typer) =
+ fun id ceff_list ->
+ try let _ = int_of_string (Ident.to_string id) in
+ (match ceff_list with
+ | [] -> [Int_type_eff]
+ | x -> (arity_error x "0"))
+ with Failure "int_of_string" ->
+ raise (EvalType_error(
+ Printf.sprintf "Error when conterting %s into an int"
+ (Ident.to_string id)))
+
+let (sb_typer: typer) = function
+ | [] -> [Bool_type_eff]
+ | x -> (arity_error x "0")
+
+let (fi_typer: typer) = function
+ | [Real_type_eff] -> [Int_type_eff]
+ | [x] -> type_error [x] "real"
+ | x -> arity_error x "1"
+
+let (if_typer: typer) = function
+ | [Int_type_eff] -> [Real_type_eff]
+ | [x] -> type_error [x] "int"
+ | x -> arity_error x "1"
+
+let (ite_typer : typer) = function
+ | [Bool_type_eff; t; e] ->
+ if t = e then [t] else (type_error [Bool_type_eff; t; e] "bool*any*any")
+ | x -> (arity_error x "3")
+
+let (boolred_typer : typer) =
+ fun ceff_list ->
+ let _ = List.fold_left
+ (fun acc ceff ->
+ match (ceff) with
+ | (Bool_type_eff) -> acc
+ | _ -> (type_error [ceff] "bool")
+ )
+ true
+ ceff_list
+ in
+ [Bool_type_eff]
+
+(* exported *)
+let (type_eval: op -> typer) = function
+ | TRUE_n
+ | FALSE_n -> sb_typer
+ | ICONST_n id -> si_typer id
+ | RCONST_n id -> sf_typer id
+ | NOT_n -> bb_typer
+ | REAL2INT_n -> fi_typer
+ | INT2REAL_n -> if_typer
+ | AND_n
+ | OR_n
+ | XOR_n
+ | IMPL_n -> bbb_typer
+ | EQ_n
+ | NEQ_n
+ | LT_n
+ | LTE_n
+ | GT_n
+ | GTE_n -> aab_typer
+ | DIV_n
+ | IPOWER_n
+ | MOD_n -> iii_typer
+ | IF_n -> ite_typer
+ | UMINUS_n -> oo_typer
+ | POWER_n
+ | MINUS_n
+ | PLUS_n
+ | SLASH_n
+ | TIMES_n -> ooo_typer
+ | IUMINUS_n -> ii_typer
+ | IMINUS_n
+ | IPLUS_n
+ | ISLASH_n
+ | ITIMES_n -> iii_typer
+ | RUMINUS_n -> ff_typer
+ | RMINUS_n
+ | RPLUS_n
+ | RSLASH_n
+ | RTIMES_n
+ | RPOWER_n -> fff_typer
+ | NOR_n
+ | DIESE_n -> boolred_typer
+
+(*********************************************************************************)
+
+let (bbb_evaluator:(bool -> bool -> bool) -> const_evaluator) =
+ fun op -> function
+ | [Bool_const_eff v0; Bool_const_eff v1] -> [Bool_const_eff (op v0 v1)]
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (ooo_evaluator:(int -> int -> int) -> (float -> float -> float) ->
+ const_evaluator) =
+ fun opi opr -> function
+ | [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 ??? *)
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (iii_evaluator:(int -> int -> int) -> const_evaluator) =
+ fun op -> function
+ | [Int_const_eff v0; Int_const_eff v1] -> [Int_const_eff (op v0 v1)]
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (aab_evaluator:('a -> 'a -> bool) -> const_evaluator) =
+ fun op -> function
+ | [v0; v1] -> [Bool_const_eff (op v0 v1)]
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (fff_evaluator:(float -> float -> float) -> const_evaluator) =
+ fun op -> function
+ | [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 -> function
+ | [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 -> function
+ | [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 -> function
+ | [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 -> function
+ | [Int_const_eff v0] -> [Int_const_eff (opi v0)]
+ | [Real_const_eff v0] -> [Real_const_eff (opr v0)]
+ (* 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_list ->
+ 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 "Error when conterting %s into a float"
+ (Ident.to_string id)))
+
+let (si_evaluator: Ident.t -> const_evaluator) =
+ fun id ceff_list ->
+ try let v = int_of_string (Ident.to_string id) in
+ [Int_const_eff v]
+ with Failure "int_of_string" ->
+ raise (EvalConst_error(
+ Printf.sprintf "Error when conterting %s into an int"
+ (Ident.to_string id)))
+
+let (sb_evaluator: bool -> const_evaluator) =
+ fun v ceff_list ->
+ [Bool_const_eff v]
+
+let (fi_evaluator:(float -> int) -> const_evaluator) =
+ fun op -> function
+ | [Real_const_eff v0] -> [Int_const_eff (op v0)]
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (if_evaluator: (int -> float) -> const_evaluator) =
+ fun op -> function
+ | [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]
+ | _ -> assert false (* should not occur because eval_type is called before *)
+
+let (boolred_evaluator : int -> const_evaluator) =
+ fun max ceff_list ->
+ let nb = List.fold_left
+ (fun acc -> function
+ | (Bool_const_eff b) -> if b then acc+1 else acc | _ -> assert false)
+ 0
+ ceff_list
+ in
+ [Bool_const_eff (nb <= max)]
+
+
+(* exported *)
+let (const_eval: op -> const_evaluator) =
+ fun op l ->
+ (* we first check the type so that we do not need to check it during the const
+ evaluation *)
+ ignore (type_eval op (List.map type_of_const_eff l));
+ match op with
+ | TRUE_n -> sb_evaluator true l
+ | FALSE_n -> sb_evaluator false l
+ | ICONST_n id -> si_evaluator id l
+ | RCONST_n id -> sf_evaluator id l
+ | NOT_n -> bb_evaluator (not) l
+ | REAL2INT_n -> fi_evaluator int_of_float l
+ | INT2REAL_n -> if_evaluator float_of_int l
+ | AND_n -> bbb_evaluator (&&) l
+ | OR_n -> bbb_evaluator (||) l
+ | XOR_n -> bbb_evaluator (<>) l
+ | IMPL_n -> bbb_evaluator (fun a b -> (not a) || b) l
+ | EQ_n -> aab_evaluator (=) l
+ | NEQ_n -> aab_evaluator (<>) l
+ | LT_n -> aab_evaluator (<) l
+ | LTE_n -> aab_evaluator (<=) l
+ | GT_n -> aab_evaluator (>) l
+ | GTE_n -> aab_evaluator (>=) l
+ | DIV_n -> iii_evaluator (/) l
+ | MOD_n -> iii_evaluator (mod) l
+ | IF_n -> ite_evaluator l
+ | UMINUS_n -> oo_evaluator (fun x -> -x) (fun x -> -.x) l
+ | MINUS_n -> ooo_evaluator (-) (-.) l
+ | PLUS_n -> ooo_evaluator (+) (+.) l
+ | SLASH_n -> ooo_evaluator (/) (/.) l
+ | TIMES_n -> ooo_evaluator ( * ) ( *.) l
+ | IUMINUS_n -> ii_evaluator (fun x -> -x) l
+ | IMINUS_n -> iii_evaluator (-) l
+ | IPLUS_n -> iii_evaluator (+) l
+ | ISLASH_n -> iii_evaluator (/) l
+ | ITIMES_n -> iii_evaluator ( * ) l
+ | RUMINUS_n -> ff_evaluator (fun x -> -.x) l
+ | RMINUS_n -> fff_evaluator (-.) l
+ | RPLUS_n -> fff_evaluator (+.) l
+ | RSLASH_n -> fff_evaluator (/.) l
+ | RTIMES_n -> fff_evaluator ( *.) l
+ | RPOWER_n -> fff_evaluator ( ** ) l
+ | NOR_n -> boolred_evaluator 0 l
+ | DIESE_n -> boolred_evaluator 1 l
+
+ | POWER_n
+ | IPOWER_n ->
+ not_evaluable op l
+
+
+(*********************************************************************************)
+let finish_me msg =
+ print_string ("\n\tXXX predefSemantics.ml:"^msg^" -> finish me!\n")
+
+
+let (aa_clocker: clocker) =
+ function
+ | [clk1] -> [clk1]
+ | _ -> finish_me "a good error msg"; assert false
+
+let (aaa_clocker: clocker) =
+ function
+ | [clk1; clk2] ->
+ if clk1 = clk2 then [clk1] else (finish_me "a good error msg"; assert false)
+ | _ ->
+ finish_me "a good error msg"; assert false
+
+
+
+(* This table contains the clock profile of predefined operators *)
+let (clocking_tab: op -> clocker) =
+ fun op ->
+ assert false
+
+(*********************************************************************************)
+(* Automatically generate the latex documentation associated to predefined
+ entities *)
+
+let (gen_tex_doc : string -> unit) =
+ fun file ->
+ let oc = open_out file in
+ let p = output_string oc in
+ p " Lustre V6 predefined operators \n\n";
+ List.iter (fun (n,def) -> p ("\t" ^ n ^ "\n")) list;
+ close_out oc
+
+(*********************************************************************************)
+(*********************************************************************************)
+(*
+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
+ ----------------------------*)
+ 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
+
+ | [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/predefSemantics.mli b/src/predefSemantics.mli
new file mode 100644
index 0000000000000000000000000000000000000000..615b4d5fadb3343c626a17a52fc40a0609ebcb6d
--- /dev/null
+++ b/src/predefSemantics.mli
@@ -0,0 +1,36 @@
+(** Time-stamp: <modified the 20/03/2008 (at 10:56) by Erwan Jahier> *)
+
+(**
+ As far as predefined operators are concerned, typing, clock checking, and constant
+ evaluation are very similar tasks. It consists in:
+
+ - checking the arity
+ - checking (recursively) the arguments
+ - apply a rule associated to the operator that says, given a list
+ of checked arguments, what is the "result" of the operator call.
+
+ That's why we gathered those three activities in this module.
+
+ nb: the whole operational semantics of predefined operators is
+ defined by this module.
+*)
+
+
+(** An evaluator returns a list because Lustre calls returns tuples.
+
+ SE: migth raise some check error!
+*)
+type 'a evaluator = 'a list -> 'a list
+
+type typer = type_eff evaluator
+type const_evaluator = const_eff evaluator
+type clocker = clock_eff evaluator
+
+
+exception EvalConst_error of string
+
+(* that says how to statically evaluate constants *)
+val const_eval: Predef.op -> const_evaluator
+
+(* provides the type profile of predef operators *)
+val type_eval: op -> typer
diff --git a/src/syntaxTreeCore.ml b/src/syntaxTreeCore.ml
index 153fdf92cb7e4c751757d1226dfe15fa3c682a24..32efc6ecb9c9adcd06d9a9e88a0a48a56006ddaf 100644
--- a/src/syntaxTreeCore.ml
+++ b/src/syntaxTreeCore.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 13/03/2008 (at 15:31) by Erwan Jahier> *)
+(** Time-stamp: <modified the 20/03/2008 (at 11:35) by Erwan Jahier> *)
(** (Raw) Abstract syntax tree of source programs. *)
@@ -86,68 +86,30 @@ and slice_info = {
and by_pos_op =
(* zeroaire *)
- | TRUE_n
- | FALSE_n
- | ICONST_n of Ident.t
- | RCONST_n of Ident.t
+ | Predef of Predef.op
+ | CALL_n of node_exp srcflagged
| IDENT_n of Ident.idref
-(* unaires *)
- | NOT_n
- | CURRENT_n
- | REAL2INT_n
- | INT2REAL_n
-(* binaires *)
- | AND_n
- | OR_n
- | XOR_n
- | IMPL_n
- | EQ_n
- | NEQ_n
- | LT_n
- | LTE_n
- | GT_n
- | GTE_n
- | DIV_n
- | MOD_n
-
-(* ternaires *)
- | IF_n
-(* n-aires *)
- | NOR_n
- | DIESE_n
-
-(* overloaded operator *)
- | UMINUS_n
- | MINUS_n
- | PLUS_n
- | SLASH_n
- | TIMES_n
- | POWER_n
| PRE_n
-
- (* pseudo-unaire : appel par position *)
- | CALL_n of node_exp srcflagged
-
-(* operator that do not generate any op call *)
| ARROW_n
| FBY_n
+ | CURRENT_n
+ | MERGE_n of (Ident.t * (Ident.t list))
+
| WHEN_n
- | HAT_n
- | CONCAT_n
| TUPLE_n
- | ARRAY_n
| WITH_n
- (* pseudo-unaire : acces tableau *)
+ | CONCAT_n
+ | HAT_n
+ | ARRAY_n
| ARRAY_ACCES_n of val_exp
| ARRAY_SLICE_n of slice_info
- (* pseudo-unaire : acces structure *)
- | STRUCT_ACCESS_n of Ident.t
- | MERGE_n of (Ident.t * (Ident.t list))
+
+ | STRUCT_ACCESS_n of Ident.t
+
+ | ITERATOR_n of (Ident.t * Ident.t * val_exp) (* iter name, node name, array size *)
- | ITERATOR_n of (Ident.t * Ident.t * val_exp)
- (** iterator name, node ident, array size *)
(************************************************)
(* Info associées aux expressions *)
@@ -230,20 +192,3 @@ type item_info =
| TypeInfo of type_info
| NodeInfo of node_info
-(**********************************************************************************)
-
-(** Utilitaries to build [val_exp] *)
-
-let leafexp lxm op = CallByPos({src = lxm ; it = op }, Oper [])
-
-let unexp lxm op e1 = CallByPos( {src = lxm ; it = op }, Oper [e1] )
-
-let binexp lxm op e1 e2 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2] )
-
-let ternexp lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2; e3] )
-
-let naryexp lxm op elst = CallByPos( {src = lxm ; it = op }, Oper elst )
-
-
-let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )
-
diff --git a/src/syntaxTreeDump.ml b/src/syntaxTreeDump.ml
index b5c20780ca138109fe4cf9381f3a229a1cbf0011..56a54dffaa584a4c266d61ca1bbc47402b39701b 100644
--- a/src/syntaxTreeDump.ml
+++ b/src/syntaxTreeDump.ml
@@ -1,7 +1,8 @@
-(** Time-stamp: <modified the 11/03/2008 (at 15:48) by Erwan Jahier> *)
+(** Time-stamp: <modified the 20/03/2008 (at 11:37) by Erwan Jahier> *)
open Lxm
+open Predef
open SyntaxTree
open SyntaxTreeCore
open Format
@@ -13,56 +14,23 @@ let (op2string : SyntaxTreeCore.by_pos_op -> string) =
fun op ->
match op with
(* unaires *)
- | (NOT_n ) -> "not"
- | (UMINUS_n ) -> "-"
+ | Predef op -> Predef.op2string op
| (PRE_n ) -> "pre"
| (CURRENT_n) -> "current"
(* binaires *)
| (ARROW_n ) -> "->"
| (WHEN_n ) -> "when"
- | (AND_n ) -> "and"
- | (OR_n ) -> "or"
- | (XOR_n ) -> "xor"
- | (IMPL_n ) -> "=>"
- | (EQ_n ) -> "="
- | (NEQ_n ) -> "<>"
- | (LT_n ) -> "<"
- | (LTE_n ) -> "<="
- | (GT_n ) -> ">"
- | (GTE_n ) -> ">="
- | (DIV_n ) -> "div"
- | (MOD_n ) -> "mod"
- | (MINUS_n ) -> "-"
- | (PLUS_n ) -> "+"
- | (SLASH_n ) -> "/"
- | (TIMES_n ) -> "*"
- | (POWER_n ) -> "**"
| (HAT_n ) -> "^"
| (CONCAT_n ) -> "|"
- | (IDENT_n _) -> assert false
- | (RCONST_n _)-> assert false
- | (ICONST_n _)-> assert false
- | (FBY_n ) -> assert false
- | (INT2REAL_n)-> assert false
- | (REAL2INT_n)-> assert false
- | (FALSE_n ) -> assert false
- | (TRUE_n ) -> assert false
- (* ternaires *)
- | (IF_n ) -> "if"
+ | (IDENT_n idref) -> Ident.string_of_idref idref
+ | (FBY_n ) -> "fby"
| (WITH_n ) -> "with"
- (* n-aires *)
- | (NOR_n ) -> "nor"
- | (DIESE_n ) -> "#"
| (TUPLE_n ) -> assert false
| (CALL_n _ ) -> assert false
- (* tableau (spécial) *)
| (ARRAY_n ) -> assert false
- (* pseudo-unaire : acces tableau *)
| (ARRAY_ACCES_n _ ) -> assert false
| (ARRAY_SLICE_n sl) -> assert false
- (* pseudo-unaire : acces structure *)
| (STRUCT_ACCESS_n fld) -> assert false
-
| ITERATOR_n _ -> assert false
| MERGE_n _ -> assert false
@@ -394,61 +362,69 @@ and dump_val_exp_list (os : formatter) (xl: val_exp list) = (
and dump_by_pos_exp (os: Format.formatter) (oper: by_pos_op) (pars: operands) =
(
match (oper, pars) with
- (TRUE_n, Oper []) -> dump_leaf_exp os "true"
- | (FALSE_n, Oper []) -> dump_leaf_exp os "false"
- | (ICONST_n s, Oper []) -> dump_leaf_exp os (Ident.to_string s)
- | (RCONST_n s, Oper []) -> dump_leaf_exp os (Ident.to_string s)
+ (Predef TRUE_n, Oper []) -> dump_leaf_exp os "true"
+ | (Predef FALSE_n, Oper []) -> dump_leaf_exp os "false"
+ | (Predef (ICONST_n s), Oper []) -> dump_leaf_exp os (Ident.to_string s)
+ | (Predef (RCONST_n s), Oper []) -> dump_leaf_exp os (Ident.to_string s)
| (IDENT_n id,Oper []) -> dump_leaf_exp os (Ident.string_of_idref id)
(* unaires *)
- | (NOT_n, Oper [p0]) -> dump_unary_exp os "not" p0
- | (UMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef NOT_n, Oper [p0]) -> dump_unary_exp os "not" p0
+ | (Predef UMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef RUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef IUMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
| (PRE_n, Oper [p0]) -> dump_unary_exp os "pre" p0
| (CURRENT_n, Oper [p0]) -> dump_unary_exp os "current" p0
- | (REAL2INT_n, Oper [p0]) -> dump_unary_exp os "int" p0
- | (INT2REAL_n, Oper [p0]) -> dump_unary_exp os "real" p0
+ | (Predef REAL2INT_n, Oper [p0]) -> dump_unary_exp os "int" p0
+ | (Predef INT2REAL_n, Oper [p0]) -> dump_unary_exp os "real" p0
(* binaires *)
| (ARROW_n, Oper [p0;p1]) -> dump_binary_exp os "->" p0 p1
| (FBY_n, Oper [p0;p1]) -> dump_binary_exp os "fby" p0 p1
| (WHEN_n, Oper [p0;p1]) -> dump_binary_exp os "when" p0 p1
- | (AND_n, Oper [p0;p1]) -> dump_binary_exp os "and" p0 p1
- | (OR_n, Oper [p0;p1]) -> dump_binary_exp os "or" p0 p1
- | (XOR_n, Oper [p0;p1]) -> dump_binary_exp os "xor" p0 p1
- | (IMPL_n, Oper [p0;p1]) -> dump_binary_exp os "=>" p0 p1
- | (EQ_n, Oper [p0;p1]) -> dump_binary_exp os "=" p0 p1
- | (NEQ_n, Oper [p0;p1]) -> dump_binary_exp os "<>" p0 p1
- | (LT_n, Oper [p0;p1]) -> dump_binary_exp os "<" p0 p1
- | (LTE_n, Oper [p0;p1]) -> dump_binary_exp os "<=" p0 p1
- | (GT_n, Oper [p0;p1]) -> dump_binary_exp os ">" p0 p1
- | (GTE_n, Oper [p0;p1]) -> dump_binary_exp os ">=" p0 p1
- | (DIV_n, Oper [p0;p1]) -> dump_binary_exp os "div" p0 p1
- | (MOD_n, Oper [p0;p1]) -> dump_binary_exp os "mod" p0 p1
- | (MINUS_n, Oper [p0;p1]) -> dump_binary_exp os "-" p0 p1
- | (PLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
- | (SLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
- | (TIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
- | (POWER_n, Oper [p0;p1]) -> dump_binary_exp os "**" p0 p1
+ | (Predef AND_n, Oper [p0;p1]) -> dump_binary_exp os "and" p0 p1
+ | (Predef OR_n, Oper [p0;p1]) -> dump_binary_exp os "or" p0 p1
+ | (Predef XOR_n, Oper [p0;p1]) -> dump_binary_exp os "xor" p0 p1
+ | (Predef IMPL_n, Oper [p0;p1]) -> dump_binary_exp os "=>" p0 p1
+ | (Predef EQ_n, Oper [p0;p1]) -> dump_binary_exp os "=" p0 p1
+ | (Predef NEQ_n, Oper [p0;p1]) -> dump_binary_exp os "<>" p0 p1
+ | (Predef LT_n, Oper [p0;p1]) -> dump_binary_exp os "<" p0 p1
+ | (Predef LTE_n, Oper [p0;p1]) -> dump_binary_exp os "<=" p0 p1
+ | (Predef GT_n, Oper [p0;p1]) -> dump_binary_exp os ">" p0 p1
+ | (Predef GTE_n, Oper [p0;p1]) -> dump_binary_exp os ">=" p0 p1
+ | (Predef DIV_n, Oper [p0;p1]) -> dump_binary_exp os "div" p0 p1
+ | (Predef MOD_n, Oper [p0;p1]) -> dump_binary_exp os "mod" p0 p1
+ | (Predef MINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef RMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef IMINUS_n, Oper [p0]) -> dump_unary_exp os "-" p0
+ | (Predef PLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (Predef RPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (Predef IPLUS_n, Oper [p0;p1]) -> dump_binary_exp os "+" p0 p1
+ | (Predef SLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (Predef RSLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (Predef ISLASH_n, Oper [p0;p1]) -> dump_binary_exp os "/" p0 p1
+ | (Predef TIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (Predef RTIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (Predef ITIMES_n, Oper [p0;p1]) -> dump_binary_exp os "*" p0 p1
+ | (Predef POWER_n, Oper [p0;p1]) -> dump_binary_exp os "**" p0 p1
+ | (Predef RPOWER_n, Oper [p0;p1]) -> dump_binary_exp os "**" p0 p1
+ | (Predef IPOWER_n, Oper [p0;p1]) -> dump_binary_exp os "**" p0 p1
| (HAT_n, Oper [p0;p1]) -> dump_binary_exp os "^" p0 p1
| (CONCAT_n, Oper [p0;p1]) -> dump_binary_exp os "|" p0 p1
- (* ternaires *)
- | (IF_n, Oper [p0;p1;p2]) -> dump_ternary_exp os "if" "then" "else" p0 p1 p2
+ | (Predef IF_n, Oper [p0;p1;p2]) -> dump_ternary_exp os "if" "then" "else" p0 p1 p2
| (WITH_n, Oper [p0;p1;p2]) -> dump_ternary_exp os "with" "then" "else" p0 p1 p2
- (* n-aires *)
- | (NOR_n, Oper pl) -> dump_nary_exp os "nor" pl
- | (DIESE_n, Oper pl) -> dump_nary_exp os "#" pl
+ | (Predef NOR_n, Oper pl) -> dump_nary_exp os "nor" pl
+ | (Predef DIESE_n, Oper pl) -> dump_nary_exp os "#" pl
| (TUPLE_n, Oper pl) -> dump_nary_exp os "" pl
| (CALL_n s, Oper pl) -> fprintf os "%a(@,%a@,)"
dump_node_exp s.it dump_val_exp_list pl
- (* tableau (spécial) *)
| (ARRAY_n, Oper pl) -> fprintf os "[@,%a@,]" dump_val_exp_list pl
- (* pseudo-unaire : acces tableau *)
| (ARRAY_ACCES_n ix, Oper [p0]) -> fprintf os "%a[@,%a@,]"
dump_val_exp p0 dump_val_exp ix
| (ARRAY_SLICE_n sl, Oper [p0]) -> fprintf os "%a[@,%a@,]"
dump_val_exp p0 dump_slice_info sl
- (* pseudo-unaire : acces structure *)
| (STRUCT_ACCESS_n fld, Oper [p0]) -> fprintf os "%a.%s"
dump_val_exp p0 (Ident.to_string fld)
+ | (Predef _,_) -> assert false
| (ITERATOR_n _, _) -> assert false
| (MERGE_n _,_) -> assert false
@@ -458,39 +434,15 @@ and dump_by_pos_exp (os: Format.formatter) (oper: by_pos_op) (pars: operands) =
| (ARRAY_SLICE_n _, _) -> assert false
| (ARRAY_ACCES_n _, _) -> assert false
| (WITH_n, _) -> assert false
- | (IF_n, _) -> assert false
| (CONCAT_n, _) -> assert false
| (HAT_n, _) -> assert false
- | (POWER_n, _) -> assert false
- | (TIMES_n, _) -> assert false
- | (SLASH_n, _) -> assert false
- | (PLUS_n, _) -> assert false
- | (MINUS_n, _) -> assert false
- | (MOD_n, _) -> assert false
- | (DIV_n, _) -> assert false
- | (GTE_n, _) -> assert false
- | (GT_n, _) -> assert false
- | (LTE_n, _) -> assert false
- | (LT_n, _) -> assert false
- | (NEQ_n, _) -> assert false
- | (EQ_n, _) -> assert false
- | (IMPL_n, _) -> assert false
- | (XOR_n, _) -> assert false
- | (OR_n, _) -> assert false
- | (AND_n, _) -> assert false
+
+
| (WHEN_n, _) -> assert false
| (ARROW_n, _) -> assert false
- | (INT2REAL_n, _) -> assert false
- | (REAL2INT_n, _) -> assert false
| (CURRENT_n, _) -> assert false
| (PRE_n, _) -> assert false
- | (UMINUS_n, _) -> assert false
- | (NOT_n, _) -> assert false
| (IDENT_n _, _) -> assert false
- | (RCONST_n _, Oper (_::_)) -> assert false
- | (ICONST_n _, Oper (_::_)) -> assert false
- | (FALSE_n, Oper (_::_)) -> assert false
- | (TRUE_n, Oper (_::_)) -> assert false
)
(* les procs standard pour les operateurs predefs *)
diff --git a/src/test/test.res.exp b/src/test/test.res.exp
index 7d0946e700f93175ce84d051d25cfc114a349255..c7a77efdc1731f6c6802e2acdafcc10fe497af02 100644
--- a/src/test/test.res.exp
+++ b/src/test/test.res.exp
@@ -2599,11 +2599,16 @@ End of Syntax table dump.
Exported constants:
const dummy::size = 16
const dummy::right = 1.570800
-Warning. in file "should_work/NONREG/simple.lus", line 11, col 17 to 17, token '/':
----> float in static exp: 3.141600/2.000000 evaluated as 1.570800
+ const dummy::u = false
+ const dummy::pi = 3.141600
+ const dummy::c = true
+ Exported nodes:
+ node dummy::simple = dummy::simple(bool, {a : int; b : {x : dummy::S; y : int}}) returns (int) on clock XXX
+
+ node dummy::f1 = dummy::f1(int) returns (int) on clock XXX
+
+ node dummy::f2 = dummy::f2(int, int) returns (bool, int) on clock XXX
-*** oops: an internal error occurred in file evalConst.ml, line 299, column 16
-*** when compiling lustre program should_work/NONREG/simple.lus
----------------------------------------------------------------------
====> ../lus2lic -vl 3 should_work/NONREG/stopwatch.lus
@@ -3021,7 +3026,7 @@ End of Syntax table dump.
XXX getEff.ml:
XXX in file "should_work/Pascal/newpacks.lus", line 52, col 13 to 22, token 'pint::fby1': imported node preal::fby1 in static args -> finish me!
-*** oops: an internal error occurred in file getEff.ml, line 27, column 3
+*** oops: an internal error occurred in file getEff.ml, line 54, column 3
*** when compiling lustre program should_work/Pascal/newpacks.lus
----------------------------------------------------------------------
@@ -3249,7 +3254,7 @@ End of Syntax table dump.
XXX getEff.ml:
XXX in file "should_work/Pascal/p.lus", line 53, col 13 to 22, token 'pint::fby1': imported node preal::fby1 in static args -> finish me!
-*** oops: an internal error occurred in file getEff.ml, line 27, column 3
+*** oops: an internal error occurred in file getEff.ml, line 54, column 3
*** when compiling lustre program should_work/Pascal/p.lus
----------------------------------------------------------------------
@@ -3343,7 +3348,7 @@ End of Syntax table dump.
XXX getEff.ml:
XXX in file "should_work/Pascal/packs.lus", line 40, col 13 to 22, token 'pint::fby1': imported node preal::fby1 in static args -> finish me!
-*** oops: an internal error occurred in file getEff.ml, line 27, column 3
+*** oops: an internal error occurred in file getEff.ml, line 54, column 3
*** when compiling lustre program should_work/Pascal/packs.lus
----------------------------------------------------------------------
@@ -4143,7 +4148,7 @@ End of Syntax table dump.
XXX getEff.ml:
XXX calcul de ARRAY_SLICE_eff -> finish me!
-*** oops: an internal error occurred in file getEff.ml, line 264, column 3
+*** oops: an internal error occurred in file getEff.ml, line 229, column 3
*** when compiling lustre program should_work/demo/filliter.lus
----------------------------------------------------------------------
@@ -4356,7 +4361,7 @@ End of Syntax table dump.
Exported types:
Exported constants:
Exported nodes:
-*** Error in file "should_work/demo/plus.lus", line 3, col 7 to 19, token 'Lustre::iplus': unknown node
+*** Error in file "should_work/demo/plus.lus", line 5, col 12 to 18, token 'boolred': unknown node
----------------------------------------------------------------------
@@ -6198,7 +6203,7 @@ End of Syntax table dump.
XXX getEff.ml:
XXX in file "should_work/packEnvTest/packages.lus", line 53, col 13 to 22, token 'pint::fby1': imported node preal::fby1 in static args -> finish me!
-*** oops: an internal error occurred in file getEff.ml, line 27, column 3
+*** oops: an internal error occurred in file getEff.ml, line 54, column 3
*** when compiling lustre program should_work/packEnvTest/packages.lus
----------------------------------------------------------------------
@@ -6505,7 +6510,7 @@ End of Syntax table dump.
type dummy::t7 = int^3^6^3^2^12^3
type dummy::t8 = int^3^6^3^2^12^3^3
Exported constants:
-*** Error in file "should_fail/semantics/const2.lus", line 4, col 13 to 16, token 'when': can't eval constant: operation when not allowed in static expression
+*** Error in file "should_fail/semantics/const2.lus", line 4, col 24 to 25, token '->': can't eval constant: The construct -> is not allowed in static expression
const dummy::c10 = 12
@@ -6741,6 +6746,6 @@ End of Syntax table dump.
type dummy::t7 = int^3^7^8^9^3^8
type dummy::t8 = int^3^7^8^9^3^8^8
Exported constants:
-*** Error in file "should_fail/type/const2.lus", line 16, col 12 to 13, token '<>': can't eval constant: type combination error, t*t for some type t expected
+*** Error in file "should_fail/type/const2.lus", line 16, col 12 to 13, token '<>': type error: type mismatch
const dummy::c10 = 3