From de984fca1a04d043801ce28257e0133faf2c03c3 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Mon, 26 May 2008 16:52:48 +0200
Subject: [PATCH] Add error messages when one tries to alaias a
polymporphic or a overloaded operator.
Moreover, do not try to check that int or real constant are ok. It is
the role of the host language.
---
src/TODO | 11 +++-
src/evalType.ml | 14 ++--
src/lazyCompiler.ml | 17 ++++-
src/predefSemantics.ml | 142 ++++++++++++++++++++---------------------
4 files changed, 101 insertions(+), 83 deletions(-)
diff --git a/src/TODO b/src/TODO
index 082dc741..684aa528 100644
--- a/src/TODO
+++ b/src/TODO
@@ -100,6 +100,14 @@ lazycompiler.ml:
je les ai en interne...
* splitter predefsemantics en predefTyping et PredefEval?
+ les function type_error des predefSemantics devraient être
+ definies ailleurs en ce cas.
+
+
+* autoriser les alias sur "nor" et "#" ? (ca complique les choses
+ pour bien peu...).
+
+* essayer de faire qque chose pour les 2 verrues dans predefSemantics
***********************************************************************************
***********************************************************************************
@@ -109,9 +117,8 @@ lazycompiler.ml:
*** facile
-* les function type_error des predefSemantics devraient être definies ailleurs
-* essayer de faire qque chose pour les 2 verrues dans predefSemantics
+
* iterateur sur des operateur predefinis : ca ne peut pas marcher
tant que StaticParamNode (cd SyntaxTreeCore.static_param) stocke un
diff --git a/src/evalType.ml b/src/evalType.ml
index 9584172a..5a38e6e4 100644
--- a/src/evalType.ml
+++ b/src/evalType.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/05/2008 (at 10:55) by Erwan Jahier> *)
+(** Time-stamp: <modified the 26/05/2008 (at 15:48) by Erwan Jahier> *)
open Predef
@@ -34,9 +34,9 @@ and (eval_by_pos_type :
| CALL_eff node_exp_eff ->
let lto = snd (List.split node_exp_eff.it.outlist_eff) in
List.map
- (function
- | Atype t -> t
- | (Any | Overload) -> assert false (* cannot occur for user node *)
+ (function
+ | Atype t -> t
+ | (Any | Overload) -> assert false (* cannot occur for user node *)
)
lto
| IDENT_eff id -> (
@@ -48,14 +48,14 @@ and (eval_by_pos_type :
match args with
[a0;a1;a2] -> (
match (f id_solver a0) with
- | [Bool_type_eff] ->
+ | [Bool_type_eff] ->
let teff1 = f id_solver a1
and teff2 = f id_solver a2 in
if teff1 = teff2 then teff1 else
type_error [] "type mismatch in with statements"
| x -> type_error x "bool"
)
- | _ ->
+ | _ ->
raise (EvalType_error(sprintf "arity error: 3 expected instead of %d"
(List.length args)))
)
@@ -66,7 +66,7 @@ and (eval_by_pos_type :
| [[Array_type_eff (teff0, size0)]; [Array_type_eff (teff1, size1)]] -> (
if teff0 = teff1 then
[Array_type_eff (teff0, size0+size1)]
- else
+ else
raise(EvalType_error(
sprintf "type combination error, can't concat %s with %s"
(CompiledDataDump.string_of_type_eff teff0)
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 7e4d9c13..ab24f7a7 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/05/2008 (at 14:58) by Erwan Jahier> *)
+(** Time-stamp: <modified the 26/05/2008 (at 16:42) by Erwan Jahier> *)
open Lxm
@@ -658,6 +658,21 @@ and (node_check_do: t -> CompiledData.node_key -> Lxm.t -> SymbolTab.t ->
| Alias({it= alias;src=lxm}) -> (
let aliased_node =
match alias with
+ | Predef((Predef.NOR_n|Predef.DIESE_n), sargs) ->
+ raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
+ | Predef(
+ (Predef.NEQ_n | Predef.EQ_n | Predef.LT_n | Predef.LTE_n
+ | Predef.GT_n | Predef.GTE_n | Predef.IF_n), _sargs
+ ) ->
+ raise (Compile_error (
+ lxm, "can not alias polymorphic operators, sorry"))
+ | Predef(
+ ( Predef.UMINUS_n | Predef.MINUS_n | Predef.PLUS_n
+ | Predef.TIMES_n | Predef.SLASH_n), _sargs
+ ) ->
+ raise (Compile_error (
+ lxm, "can not alias overloaded operators, sorry"))
+
| Predef(predef_op, sargs) ->
let sargs_eff =
GetEff.translate_predef_static_args node_id_solver sargs lxm
diff --git a/src/predefSemantics.ml b/src/predefSemantics.ml
index 5c90a2ec..b8a13ae6 100644
--- a/src/predefSemantics.ml
+++ b/src/predefSemantics.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 26/05/2008 (at 15:09) by Erwan Jahier> *)
+(** Time-stamp: <modified the 26/05/2008 (at 16:51) by Erwan Jahier> *)
open Predef
@@ -13,7 +13,6 @@ type typer = type_eff evaluator
type const_evaluator = const_eff evaluator
type clocker = clock_eff evaluator
-let finish_me msg = print_string ("\n\tXXX predefSemantics.ml:"^msg^" -> finish me!\n")
(*********************************************************************************)
exception EvalConst_error of string
@@ -72,10 +71,12 @@ let not_evaluable op l =
(op2string op)))
(*********************************************************************************)
-(**
- This unify function is quite specific. It can only unify 2 lists
+(** This unify function is quite specific. It can only unify 2 lists
with at most one type variable (Any); we also suppose that the
second list have no Any type.
+
+ Moreover, it deals with the concept of overloaded variable. Currently,
+ an overloaded variable is polymorphic var that can only be an int or a real.
[unify] has 3 kinds of results:
- the 2 lists are equal
@@ -89,35 +90,34 @@ type unify_result =
let var_type2str = CompiledDataDump.string_of_var_type
let type_eff2str = CompiledDataDump.string_of_type_eff
+
let (unify : var_type list -> var_type list -> unify_result) =
- fun l1 l2 ->
- let (is_overloadable : type_eff -> bool) = function
- | Int_type_eff -> true
- | Real_type_eff -> true
- | _ -> false
- in
- List.fold_left2
- (fun acc vt1 vt2 ->
- match acc,vt1,vt2 with
- | Ko msg , _, _ -> acc
- | Equal, Any, Atype t2 -> Unif t2
- | Equal, Overload, Atype t2 -> if is_overloadable t2 then Unif t2 else
- Ko((type_eff2str t2) ^ " should have type int or real")
-
- | (Equal|Unif _), Atype t1, Atype t2 -> if t1 = t2 then acc else
- Ko((type_eff2str t1) ^ " <> " ^ (type_eff2str t2))
-
- | Unif ts, Any, Atype t2 -> if ts = t2 then acc else
+ let (is_overloadable : type_eff -> bool) = function
+ | Int_type_eff -> true
+ | Real_type_eff -> true
+ | _ -> false
+ in
+ List.fold_left2
+ (fun acc vt1 vt2 ->
+ match acc,vt1,vt2 with
+ | Ko msg , _, _ -> acc
+ | Equal, Any, Atype t2 -> Unif t2
+ | Equal, Overload, Atype t2 -> if is_overloadable t2 then Unif t2 else
+ Ko((type_eff2str t2) ^ " should have type int or real")
+
+ | (Equal|Unif _), Atype t1, Atype t2 -> if t1 = t2 then acc else
+ Ko((type_eff2str t1) ^ " <> " ^ (type_eff2str t2))
+
+ | Unif ts, Any, Atype t2 -> if ts = t2 then acc else
+ Ko((type_eff2str ts) ^ " <> " ^ (type_eff2str t2))
+ | Unif ts, Overload, Atype t2 ->
+ if ts = t2 && is_overloadable t2 then acc else
Ko((type_eff2str ts) ^ " <> " ^ (type_eff2str t2))
- | Unif ts, Overload, Atype t2 ->
- if ts = t2 && is_overloadable t2 then acc else
- Ko((type_eff2str ts) ^ " <> " ^ (type_eff2str t2))
- | _,_, (Overload|Any) -> assert false (* cannot occur *)
- )
- Equal
- l1
- l2
+ | _,_, (Overload|Any) -> assert false (* cannot occur *)
+ )
+ Equal
+
(*********************************************************************************)
(* a few local alias to make the node profile below more readable. *)
@@ -133,42 +133,23 @@ let ii_profile = [(id "i", i)], [(id "o", i)] (* int -> int *)
let iii_profile = [(id "i1", i);(id "i2", i)], [(id "o", i)] (* int*int -> int *)
let rr_profile = [(id "i", r)], [(id "o", r)] (* real -> real *)
let rrr_profile = [(id "i1", r);(id "i2", r)], [(id "o", r)] (* real*real -> real *)
-let b_profile = [],[id "o", b] (* unit -> bool *)
let ri_profile = [id "i", i], [id "o", r] (* real -> int *)
let ir_profile = [id "i", r], [id "o", i] (* int -> real *)
-let bl_profile lxm = [],[] (* bool list *)
+(** Constant profiles *)
+let b_profile = [],[id "o", b]
+let i_profile = [],[id "o", i]
+let r_profile = [],[id "o", r]
-(** polymorphic operators *)
+(** polymorphic operator profiles *)
let aab_profile = [(id "i1",Any);(id "i2",Any)], [(id "o", b)] (* 'a -> 'a -> bool*)
let baaa_profile = [(id "c", b);(id "b1",Any);(id "b2",Any)], [(id "o",Any)]
(* for if-then-else *)
-(** overloaded operators *)
-let oo_profile = [(id "i",Overload)], [(id "o",Overload)]
+(** overloaded operator profiless *)
+let oo_profile = [(id "i",Overload)], [(id "o",Overload)]
let ooo_profile = [(id "i1",Overload);(id "i2",Overload)], [(id "o",Overload)]
-(** Misc profiles *)
-let si_profile = (* string -> int *)
- fun ident ->
- (* check the ident that be converted XXX is it the rigth place to do that ? *)
- (try ignore(int_of_string (Ident.to_string ident))
- with Failure "int_of_string" ->
- raise (EvalType_error(
- Printf.sprintf "\n*** fail to convert the string \"%s\" into an int"
- (Ident.to_string ident))));
- [],[id "o", i]
-
-let sr_profile = (* string -> real *)
- fun ident ->
- (try ignore (float_of_string (Ident.to_string ident))
- with Failure "float_of_string" ->
- raise (EvalType_error (
- Printf.sprintf "\n*** fail to convert the string \"%s\" into an int"
- (Ident.to_string ident))));
- [],[id "o", r]
-
-
(** iterators profiles *)
(* [type_to_array_type [x1;...;xn] c] returns the array type [x1^c;...;xn^c] *)
let (type_to_array_type:
@@ -268,8 +249,8 @@ type node_profile = (Ident.t * var_type) list * (Ident.t * var_type) list
let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
fun op lxm sargs -> match op with
| TRUE_n | FALSE_n -> b_profile
- | ICONST_n id -> si_profile id
- | RCONST_n id -> sr_profile id
+ | ICONST_n id -> i_profile
+ | RCONST_n id -> r_profile
| NOT_n -> bb_profile
| REAL2INT_n -> ri_profile
| INT2REAL_n -> ir_profile
@@ -277,15 +258,24 @@ let (op2profile : Predef.op -> Lxm.t -> static_arg_eff list -> node_profile) =
| UMINUS_n -> oo_profile
| IUMINUS_n -> ii_profile
| RUMINUS_n -> rr_profile
- | NOR_n | DIESE_n -> bl_profile lxm
- | IMPL_n | AND_n | OR_n | XOR_n -> bbb_profile
- | NEQ_n | EQ_n | LT_n | LTE_n | GT_n | GTE_n -> aab_profile
- | MINUS_n | PLUS_n | TIMES_n | SLASH_n -> ooo_profile
- | RMINUS_n | RPLUS_n | RTIMES_n | RSLASH_n -> rrr_profile
+ | IMPL_n | AND_n | OR_n | XOR_n -> bbb_profile
+ | NEQ_n | EQ_n | LT_n | LTE_n | GT_n | GTE_n -> aab_profile
+ | MINUS_n | PLUS_n | TIMES_n | SLASH_n -> ooo_profile
+ | RMINUS_n | RPLUS_n | RTIMES_n | RSLASH_n -> rrr_profile
| DIV_n | MOD_n | IMINUS_n | IPLUS_n | ISLASH_n | ITIMES_n -> iii_profile
| Red | Fill | FillRed -> fillred_profile lxm sargs
- | Map -> map_profile lxm sargs
- | BoolRed -> boolred_profile lxm sargs
+ | Map -> map_profile lxm sargs
+ | BoolRed -> boolred_profile lxm sargs
+
+ | NOR_n | DIESE_n -> assert false
+ (* XXX The current representation of node_profile prevent us
+ from being able to represent "bool list" (i.e., operator
+ of variable arity). I could extend the type node_profile,
+ but is it worth the complication just to be able to define
+ alias nodes on "nor" and "#"? Actually, even if I extend
+ this data type, I don'ty know how I could generate an
+ alias node for them anyway...
+ *)
(* exported *)
let (make_node_exp_eff : op -> Lxm.t -> static_arg_eff list -> node_exp_eff) =
@@ -308,16 +298,13 @@ let (make_node_exp_eff : op -> Lxm.t -> static_arg_eff list -> node_exp_eff) =
(* exported *)
let (type_eval : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
- fun op lxm sargs ll ->
- 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 unwrap_type = function Atype t -> t | _ -> assert false in
- let subst_type t = function Atype t -> t | Any -> t | Overload -> t in
+ fun op lxm sargs ll ->
match op with
| IF_n -> (
(* VERRUE 1 *)
- (* j'arrive pas a traiter le if de facon generique (pour l'instant...) *)
+ (* j'arrive pas a traiter le if de facon generique (pour l'instant...)
+ a cause du fait que le if peut renvoyer un tuple.
+ *)
match ll with
| [[Bool_type_eff]; t; e] ->
if t = e then t else
@@ -325,7 +312,9 @@ let (type_eval : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
| x -> (arity_error x "3")
)
| (NOR_n | DIESE_n) ->
- (* VERRUE 2 *)
+ (* VERRUE 2 : those operators have no profile, therefore i define an
+ ad-hoc check for them.
+ *)
let check_nary_iter acc ceff =
match ceff with (Bool_type_eff) -> acc | _ -> (type_error [ceff] "bool")
in
@@ -333,6 +322,11 @@ let (type_eval : op -> Lxm.t -> CompiledData.static_arg_eff list -> typer) =
[Bool_type_eff]
| _ ->
(* general case *)
+ 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 unwrap_type = function Atype t -> t | _ -> assert false in
+ let subst_type t = function Atype t -> t | Any -> t | Overload -> t in
let l = List.map (fun t -> Atype t) (List.flatten ll) in
if (List.length l <> List.length lti) then
arity_error l (string_of_int (List.length lti))
@@ -497,6 +491,8 @@ let (const_eval: op -> Lxm.t -> static_arg_eff list -> const_evaluator) =
(*********************************************************************************)
+let finish_me msg = print_string ("\n\tXXX predefSemantics.ml:"^msg^" -> finish me!\n")
+
let (aa_clocker: clocker) =
function
| [clk1] -> clk1
--
GitLab