From 221eea1644d571c1e94ed1e040540fb44be1b76f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Tue, 27 Jul 2010 17:16:35 +0200 Subject: [PATCH] Added polymorphic (=) and (<>) operators These two operators really need to be polymorphic, so they cannot be in Pervasives. a <> b is translated to not (a = b>) at parsing. --- compiler/heptagon/analysis/causality.ml | 2 +- compiler/heptagon/analysis/typing.ml | 5 +++++ compiler/heptagon/hept_printer.ml | 2 ++ compiler/heptagon/heptagon.ml | 1 + compiler/heptagon/parsing/hept_lexer.mll | 1 + compiler/heptagon/parsing/hept_parser.mly | 9 ++++++--- compiler/heptagon/parsing/hept_parsetree.ml | 1 + compiler/heptagon/parsing/hept_scoping.ml | 1 + compiler/main/hept2mls.ml | 1 + compiler/main/mls2obc.ml | 2 ++ compiler/minils/analysis/clocking.ml | 2 +- compiler/minils/minils.ml | 1 + compiler/minils/mls_printer.ml | 2 ++ compiler/minils/transformations/normalize.ml | 3 ++- lib/pervasives.epi | 4 ---- 15 files changed, 27 insertions(+), 10 deletions(-) diff --git a/compiler/heptagon/analysis/causality.ml b/compiler/heptagon/analysis/causality.ml index 515215a..c59e563 100644 --- a/compiler/heptagon/analysis/causality.ml +++ b/compiler/heptagon/analysis/causality.ml @@ -124,7 +124,7 @@ and apply op e_list = let i2 = typing e2 in let i3 = typing e3 in cseq t1 (cor i2 i3) - | (Efun _| Enode _ | Econcat | Eselect_slice + | (Eequal | Efun _| Enode _ | Econcat | Eselect_slice | Eselect_dyn | Eselect _ | Earray_fill), e_list -> ctuplelist (List.map typing e_list) | (Earray | Etuple), e_list -> diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 24f0b30..6441ceb 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -623,6 +623,11 @@ and expect const_env h expected_ty e = and typing_app const_env h op e_list = match op, e_list with + | { a_op = Eequal }, [e1;e2] -> + let typed_e1, t1 = typing const_env h e1 in + let typed_e2 = expect const_env h t1 e2 in + Tid Initial.pbool, op, [typed_e1; typed_e2] + | { a_op = Earrow }, [e1;e2] -> let typed_e1, t1 = typing const_env h e1 in let typed_e2 = expect const_env h t1 e2 in diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index ca3690f..46eeec6 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -102,6 +102,8 @@ and print_call_params ff = function and print_op ff op params e_list = match op, params, e_list with + | Eequal, _, [e1; e2] -> + fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 | Earrow, _, [e1;e2] -> print_exp ff e1; fprintf ff " -> "; print_exp ff e2 | Eifthenelse, _, [e1;e2;e3] -> fprintf ff "@["; fprintf ff "if "; print_exp ff e1; diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index ef8f87f..72e1be8 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -38,6 +38,7 @@ and desc = and app = { a_op: op; a_params: static_exp list; a_unsafe: bool } and op = + | Eequal | Etuple | Efun of fun_name | Enode of fun_name diff --git a/compiler/heptagon/parsing/hept_lexer.mll b/compiler/heptagon/parsing/hept_lexer.mll index 8dac830..2e842ec 100644 --- a/compiler/heptagon/parsing/hept_lexer.mll +++ b/compiler/heptagon/parsing/hept_lexer.mll @@ -131,6 +131,7 @@ rule token = parse | ";" {SEMICOL} | "=" {EQUAL} | "==" {EQUALEQUAL} + | "<>" {LESS_GREATER} | "&" {AMPERSAND} | "&&" {AMPERAMPER} | "||" {BARBAR} diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 3e4fca1..ba99df8 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -10,7 +10,7 @@ open Hept_parsetree %} %token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL -%token EQUAL EQUALEQUAL BARBAR COMMA BAR ARROW LET TEL +%token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL %token Constructor %token IDENT %token INT @@ -63,7 +63,7 @@ open Hept_parsetree %right ARROW %left OR %left AMPERSAND -%left INFIX0 EQUAL +%left INFIX0 EQUAL LESS_GREATER %right INFIX1 %left INFIX2 SUBTRACTIVE %left STAR INFIX3 @@ -425,7 +425,10 @@ _exp: | exp INFIX0 exp { mk_op_call $2 [$1; $3] } | exp EQUAL exp - { mk_op_call "=" [$1; $3] } + { mk_call Eequal [$1; $3] } + | exp LESS_GREATER exp + { let e = mk_exp (mk_call Eequal [$1; $3]) (Loc($startpos,$endpos)) in + mk_op_call "not" [e] } | exp OR exp { mk_op_call "or" [$1; $3] } | exp STAR exp diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 158579e..a767a28 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -41,6 +41,7 @@ and desc = and app = { a_op: op; a_params: exp list; } and op = + | Eequal | Etuple | Enode of longname | Efun of longname diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index 820ca00..0f1d7c8 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -185,6 +185,7 @@ and translate_desc loc const_env env = function app, n, e_list, None) and translate_op = function + | Eequal -> Heptagon.Eequal | Earrow -> Heptagon.Earrow | Eifthenelse -> Heptagon.Eifthenelse | Efield -> Heptagon.Efield diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index 138ee8f..cff50ae 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -196,6 +196,7 @@ let translate_iterator_type = function | Heptagon.Imapfold -> Imapfold let rec translate_op env = function + | Heptagon.Eequal -> Eequal | Heptagon.Eifthenelse -> Eifthenelse | Heptagon.Efun f -> Efun f | Heptagon.Enode f -> Enode f diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 1721dae..a691231 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -69,6 +69,8 @@ let rec translate map (si, j, s) e = let desc = match e.Minils.e_desc with | Minils.Econst v -> Econst v | Minils.Evar n -> Elhs (var_from_name map n) + | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) -> + Eop (op_from_string "=", List.map (translate map (si, j, s)) e_list) | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n -> Eop (n, List.map (translate map (si, j, s)) e_list) diff --git a/compiler/minils/analysis/clocking.ml b/compiler/minils/analysis/clocking.ml index 8c114da..ac74be9 100644 --- a/compiler/minils/analysis/clocking.ml +++ b/compiler/minils/analysis/clocking.ml @@ -62,7 +62,7 @@ let rec typing h e = in (e.e_ck <- ckofct ct; ct) and typing_op op args h e ck = match op, args with - | (Efun _ | Enode _), e_list -> + | (Eequal | Efun _ | Enode _), e_list -> (List.iter (expect h (Ck ck)) e_list; skeleton ck e.e_ty) | Etuple, e_list -> Cprod (List.map (typing h) e_list) diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 526250d..c3789b8 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -65,6 +65,7 @@ and app = { a_op: op; a_params: static_exp list; a_unsafe: bool } and be delicate about optimizations, !be careful! *) and op = + | Eequal (** arg1 = arg2 *) | Etuple (** (args) *) | Efun of fun_name (** "Stateless" longname <> (args) reset r *) | Enode of fun_name (** "Stateful" longname <> (args) reset r *) diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index f1e8119..f144c8a 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -111,6 +111,8 @@ and print_exp_desc ff = function print_every reset and print_app ff (app, args) = match app.a_op, app.a_params, args with + | Eequal, _, [e1; e2] -> + fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 | Etuple, _, a -> print_exp_tuple ff a | (Efun(f)|Enode(f)), p, a -> fprintf ff "@[%a@,%a@,%a@]" diff --git a/compiler/minils/transformations/normalize.ml b/compiler/minils/transformations/normalize.ml index fcd31a3..5aed1cf 100644 --- a/compiler/minils/transformations/normalize.ml +++ b/compiler/minils/transformations/normalize.ml @@ -146,6 +146,7 @@ let add context expected_kind ({ e_desc = de } as e) = | _ , VRef -> true | Eapp ({ a_op = Efun n }, _, _), (Exp|Act) when is_op n -> false + | Eapp ({ a_op = Eequal }, _, _), (Exp|Act) -> false | ( Emerge _ | Eapp _ | Eiterator _ | Efby _ ), Exp -> true | ( Eapp({ a_op = Efun _ | Enode _ }, _, _) | Eiterator _ | Efby _ ), Act -> true @@ -213,7 +214,7 @@ let rec translate kind context e = and translate_app kind context op e_list = match op, e_list with - | (Efun _ | Enode _), e_list -> + | (Eequal | Efun _ | Enode _), e_list -> let context, e_list = translate_list function_args_kind context e_list in context, e_list diff --git a/lib/pervasives.epi b/lib/pervasives.epi index 317775e..a7501ab 100644 --- a/lib/pervasives.epi +++ b/lib/pervasives.epi @@ -17,10 +17,6 @@ val fun (<=)(int;int) returns (bool) val fun (<=.)(float;float) returns (bool) val fun (<)(int;int) returns (bool) val fun (<.)(float;float) returns (bool) -val fun (<>)(int;int) returns (bool) -val fun (<>.)(float;float) returns (bool) -val fun (=)(int;int) returns (bool) -val fun (=.)(float;float) returns (bool) val fun (>=)(int;int) returns (bool) val fun (>=.)(float;float) returns (bool) val fun (>)(int;int) returns (bool)