Commit b69f3152 authored by jhugues's avatar jhugues
Browse files

* REAL: add cos, sin, tan, cosh, sinh, tanh, ln, exp, sqrt

          functions



git-svn-id: https://tecsw.estec.esa.int/svn/taste/trunk/ocarina@4800 129961e7-ef38-4bb5-a8f7-c9a525a55882
parent 736a099b
...@@ -31,6 +31,7 @@ ...@@ -31,6 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;
with Namet; with Namet;
with Output; with Output;
with Locations; use Locations; with Locations; use Locations;
...@@ -59,6 +60,10 @@ with Unchecked_Deallocation; ...@@ -59,6 +60,10 @@ with Unchecked_Deallocation;
package body Ocarina.Backends.REAL is package body Ocarina.Backends.REAL is
package Numerics is
new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float);
use Numerics;
use Ocarina.ME_REAL.REAL_Tree.Nodes; use Ocarina.ME_REAL.REAL_Tree.Nodes;
use Ocarina.ME_REAL.REAL_Tree.Nutils; use Ocarina.ME_REAL.REAL_Tree.Nutils;
use Ocarina.ME_REAL.REAL_Tree.Utils; use Ocarina.ME_REAL.REAL_Tree.Utils;
...@@ -1159,22 +1164,26 @@ package body Ocarina.Backends.REAL is ...@@ -1159,22 +1164,26 @@ package body Ocarina.Backends.REAL is
Ret := RT_Error; Ret := RT_Error;
return; return;
end if; end if;
V := Get_Value_Type (R1); declare
V2 := Get_Value_Type (R2); V3 : Value_Type;
V := V - V2; begin
Result := New_Value (V); V := Get_Value_Type (R1);
case V.T is V2 := Get_Value_Type (R2);
when LT_Integer => V3 := V - V2;
Ret := RT_Integer; Result := New_Value (V3);
case V.T is
when LT_Integer =>
Ret := RT_Integer;
when LT_Real => when LT_Real =>
Ret := RT_Float; Ret := RT_Float;
when others => when others =>
Display_Located_Error Display_Located_Error
(Loc (E), "expected numeric value", (Loc (E), "expected numeric value",
Fatal => True); Fatal => True);
end case; end case;
end;
when OV_Star => when OV_Star =>
declare declare
...@@ -1222,27 +1231,31 @@ package body Ocarina.Backends.REAL is ...@@ -1222,27 +1231,31 @@ package body Ocarina.Backends.REAL is
end if; end if;
when OV_Slash => when OV_Slash =>
Compute_Check_Expression (Right_Expr (E), T2, R2); declare
if T2 = RT_Error then V3 : Value_Type;
Ret := RT_Error; begin
return; Compute_Check_Expression (Right_Expr (E), T2, R2);
end if; if T2 = RT_Error then
V := Get_Value_Type (R1); Ret := RT_Error;
V2 := Get_Value_Type (R2); return;
V := V / V2; end if;
Result := New_Value (V); V := Get_Value_Type (R1);
case V.T is V2 := Get_Value_Type (R2);
when LT_Integer => V3 := V / V2;
Ret := RT_Integer; Result := New_Value (V3);
case V.T is
when LT_Integer =>
Ret := RT_Integer;
when LT_Real => when LT_Real =>
Ret := RT_Float; Ret := RT_Float;
when others => when others =>
Display_Located_Error Display_Located_Error
(Loc (E), "expected numeric value", (Loc (E), "expected numeric value",
Fatal => True); Fatal => True);
end case; end case;
end;
when OV_Power => when OV_Power =>
Compute_Check_Expression (Right_Expr (E), T2, R2); Compute_Check_Expression (Right_Expr (E), T2, R2);
...@@ -2883,6 +2896,46 @@ package body Ocarina.Backends.REAL is ...@@ -2883,6 +2896,46 @@ package body Ocarina.Backends.REAL is
Result := New_Boolean_Value (Local_Is_In); Result := New_Boolean_Value (Local_Is_In);
end; end;
when FC_Cos | FC_Sin | FC_Tan | FC_Cosh | FC_Sinh | FC_Tanh
| FC_Ln | FC_Exp | FC_Sqrt =>
declare
VT : Value_Type;
R : Value_Id;
T2 : Return_Type;
begin
Compute_Check_Expression
(First_Node (Parameters (E)), T2, R);
if T2 = RT_Error then
T := RT_Error;
return;
end if;
VT := Get_Value_Type (R);
case Code (E) is
when FC_Cos =>
Result := New_Real_Value (Cos (VT.RVal));
when FC_Sin =>
Result := New_Real_Value (Sin (VT.RVal));
when FC_Tan =>
Result := New_Real_Value (Tan (VT.RVal));
when FC_Cosh =>
Result := New_Real_Value (Cosh (VT.RVal));
when FC_Sinh =>
Result := New_Real_Value (Sinh (VT.RVal));
when FC_Tanh =>
Result := New_Real_Value (Tanh (VT.RVal));
when FC_Ln =>
Result := New_Real_Value (Log (VT.RVal));
when FC_Exp =>
Result := New_Real_Value (Exp (VT.RVal));
when FC_Sqrt =>
Result := New_Real_Value (Sqrt (VT.RVal));
when others =>
raise Program_Error;
end case;
T := RT_Float;
end;
when others => when others =>
Display_Located_Error Display_Located_Error
(Loc (E), "Unknown or not implemented verification function", (Loc (E), "Unknown or not implemented verification function",
......
...@@ -2099,9 +2099,7 @@ package body Ocarina.Analyzer.REAL is ...@@ -2099,9 +2099,7 @@ package body Ocarina.Analyzer.REAL is
begin begin
Success := True; Success := True;
while Present (N) and then Success loop while Present (N) and then Success loop
case Kind (N) is case Kind (N) is
when K_Check_Subprogram_Call when K_Check_Subprogram_Call
| K_Check_Expression | K_Check_Expression
| K_Ternary_Expression | K_Ternary_Expression
...@@ -2498,6 +2496,94 @@ package body Ocarina.Analyzer.REAL is ...@@ -2498,6 +2496,94 @@ package body Ocarina.Analyzer.REAL is
return; return;
end if; end if;
when FC_Cos | FC_Sin | FC_Tan | FC_Cosh | FC_Sinh | FC_Tanh
| FC_Ln | FC_Exp | FC_Sqrt =>
Set_Returned_Type (S, RT_Float);
declare
Is_List : Boolean := False;
Iter : Int := 0;
P, Var : Node_Id;
begin
while Present (N) and then Success loop
case Kind (N) is
when K_Check_Subprogram_Call
| K_Check_Expression
| K_Ternary_Expression
| K_Var_Reference =>
Analyze_Verification_Expression (N, Success);
if not Success then
return;
end if;
if Returned_Type (N) = RT_Integer then
null;
elsif Returned_Type (N) = RT_Int_List then
if Iter = 0 then
Is_List := True;
else
Success := False;
end if;
else
Success := False;
return;
end if;
when K_Literal =>
declare
use Ocarina.REAL_Values;
V : constant Value_Type
:= Get_Value_Type (Value (N));
begin
Success := (V.T = LT_Real);
end;
when K_Identifier =>
Var := Find_Variable (Name (N));
if No (Var) then
Display_Analyzer_Error
(No_Node,
"Could not find variable " &
Get_Name_String (Name (Identifier (N))),
Loc => Loc (N));
Success := False;
exit;
end if;
P := Make_Var_Reference (Name (N));
Set_Referenced_Var (P, Var);
Replace_Node_To_List (Parameters (S), N, P);
Analyze_Verification_Expression (P, Success);
if Success then
if Returned_Type (P) = RT_Integer then
Success := not Is_List;
elsif Returned_Type (P) = RT_Int_List then
Is_List := True;
else
Success := False;
end if;
else
return;
end if;
when others =>
Success := False;
end case;
Iter := Iter + 1;
N := Next_Node (N);
end loop;
if not Success
or else (Iter >= 1 and then Is_List) then
Display_Analyzer_Error
(No_Node,
"expected a float as parameter",
Loc => Loc (S));
return;
end if;
end;
when others => when others =>
Set_Returned_Type (S, Get_Returned_Type (Code (S))); Set_Returned_Type (S, Get_Returned_Type (Code (S)));
......
...@@ -119,7 +119,6 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -119,7 +119,6 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
P : Boolean := False; P : Boolean := False;
L : Natural := 0; L : Natural := 0;
begin begin
-- Search the last occurence of "::" -- Search the last occurence of "::"
for I in 1 .. M loop for I in 1 .. M loop
...@@ -144,8 +143,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -144,8 +143,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
-- Translate_Predefined_Sets -- -- Translate_Predefined_Sets --
------------------------------- -------------------------------
function Translate_Predefined_Sets (T : Token_Type) return Value_Id function Translate_Predefined_Sets (T : Token_Type) return Value_Id is
is
begin begin
case T is case T is
when T_Processor_Set => when T_Processor_Set =>
...@@ -198,8 +196,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -198,8 +196,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
-- Translate_Predefined_Sets -- -- Translate_Predefined_Sets --
------------------------------- -------------------------------
function Translate_Predefined_Sets (T : Value_Id) return Token_Type function Translate_Predefined_Sets (T : Value_Id) return Token_Type is
is
begin begin
case T is case T is
when SV_Processor_Set => when SV_Processor_Set =>
...@@ -252,8 +249,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -252,8 +249,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
-- Translate_Function_Code -- -- Translate_Function_Code --
----------------------------- -----------------------------
function Translate_Function_Code (T : Token_Type) return Value_Id function Translate_Function_Code (T : Token_Type) return Value_Id is
is
begin begin
case T is case T is
when T_Is_Subcomponent_Of => when T_Is_Subcomponent_Of =>
...@@ -332,6 +328,24 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -332,6 +328,24 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
return FC_Head; return FC_Head;
when T_Queue => when T_Queue =>
return FC_Queue; return FC_Queue;
when T_Cos =>
return FC_Cos;
when T_Sin =>
return FC_Sin;
when T_Tan =>
return FC_Tan;
when T_Cosh =>
return FC_Cosh;
when T_Sinh =>
return FC_Sinh;
when T_Tanh =>
return FC_Tanh;
when T_Ln =>
return FC_Ln;
when T_Exp =>
return FC_Exp;
when T_Sqrt =>
return FC_Sqrt;
when others => when others =>
DE ("Unknown REAL function"); DE ("Unknown REAL function");
return FC_Unknown; return FC_Unknown;
...@@ -343,8 +357,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -343,8 +357,7 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
-- Get_Returned_Type -- -- Get_Returned_Type --
----------------------- -----------------------
function Get_Returned_Type (T : Value_Id) return Return_Type function Get_Returned_Type (T : Value_Id) return Return_Type is
is
begin begin
case T is case T is
when FC_Is_Subcomponent_Of => when FC_Is_Subcomponent_Of =>
...@@ -407,6 +420,8 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -407,6 +420,8 @@ package body Ocarina.ME_REAL.REAL_Tree.Utils is
return RT_Unknown; return RT_Unknown;
when FC_Queue => when FC_Queue =>
return RT_Unknown; return RT_Unknown;
when FC_Cos | FC_Sin | FC_Tan =>
return RT_Float;
when others => when others =>
DE ("Unable to determine REAL function returning type"); DE ("Unable to determine REAL function returning type");
return RT_Error; return RT_Error;
......
...@@ -123,14 +123,23 @@ package Ocarina.ME_REAL.REAL_Tree.Utils is ...@@ -123,14 +123,23 @@ package Ocarina.ME_REAL.REAL_Tree.Utils is
FC_All_Equals : constant := 39; FC_All_Equals : constant := 39;
FC_Product : constant := 40; FC_Product : constant := 40;
FC_Sum : constant := 41; FC_Sum : constant := 41;
FC_Cos : constant := 42;
FC_MMax : constant := 50; FC_Sin : constant := 43;
FC_MMin : constant := 51; FC_Tan : constant := 44;
FC_MAll_Equals : constant := 52; FC_Cosh : constant := 45;
FC_MProduct : constant := 53; FC_Sinh : constant := 46;
FC_MSum : constant := 54; FC_Tanh : constant := 47;
FC_Ln : constant := 48;
FC_Unknown : constant := 55; FC_Exp : constant := 49;
FC_Sqrt : constant := 50;
FC_MMax : constant := 60;
FC_MMin : constant := 61;
FC_MAll_Equals : constant := 62;
FC_MProduct : constant := 63;
FC_MSum : constant := 64;
FC_Unknown : constant := 65;
-- return types -- return types
......
...@@ -165,6 +165,16 @@ package body Ocarina.ME_REAL.Tokens is ...@@ -165,6 +165,16 @@ package body Ocarina.ME_REAL.Tokens is
New_Token (T_List, "List"); New_Token (T_List, "List");
New_Token (T_Float, "Float"); New_Token (T_Float, "Float");
New_Token (T_Max, "Max"); New_Token (T_Max, "Max");
New_Token (T_Cos, "cos");
New_Token (T_Sin, "sin");
New_Token (T_Tan, "tan");
New_Token (T_Cosh, "cosh");
New_Token (T_Sinh, "sinh");
New_Token (T_Tanh, "tanh");
New_Token (T_Ln, "ln");
New_Token (T_Exp, "exp");
New_Token (T_Sqrt, "sqrt");
New_Token (T_LCM, "LCM"); New_Token (T_LCM, "LCM");
New_Token (T_GCD, "GCD"); New_Token (T_GCD, "GCD");
New_Token (T_Non_Null, "Non_Null"); New_Token (T_Non_Null, "Non_Null");
......
...@@ -138,6 +138,16 @@ package Ocarina.ME_REAL.Tokens is ...@@ -138,6 +138,16 @@ package Ocarina.ME_REAL.Tokens is
T_Integer, T_Integer,
T_Max, T_Max,
T_Min, T_Min,
T_Cos,
T_Sin,
T_Tan,
T_Cosh,
T_Sinh,
T_Tanh,
T_Ln,
T_Exp,
T_Sqrt,
T_Is_In, -- Checks weither list_1 is included into list_2 T_Is_In, -- Checks weither list_1 is included into list_2
T_LCM, -- Lowest Common Multiple T_LCM, -- Lowest Common Multiple
T_GCD, -- Greatest Common Divisor T_GCD, -- Greatest Common Divisor
......
...@@ -247,6 +247,7 @@ tests/real-annexes-execution/test_real_exec_02.aadl ...@@ -247,6 +247,7 @@ tests/real-annexes-execution/test_real_exec_02.aadl
tests/real-annexes-execution/test_real_exec_03.aadl tests/real-annexes-execution/test_real_exec_03.aadl
tests/real-annexes-execution/test_real_exec_04.aadl tests/real-annexes-execution/test_real_exec_04.aadl
tests/real-annexes-execution/test_real_exec_05.aadl tests/real-annexes-execution/test_real_exec_05.aadl
tests/real-annexes-execution/test_real_exec_06.aadl
tests/real-annexes-execution-environment/test_real_exec_env_01.aadl tests/real-annexes-execution-environment/test_real_exec_env_01.aadl
tests/real_units/validation.aadl tests/real_units/validation.aadl
tests/ticket_46/test.aadl tests/ticket_46/test.aadl
......
package Test5_REAL
public
-----------------
-- Subprograms --
-----------------
subprogram Hello_Spg_1
properties
source_language => Ada95;
source_name => "Hello.Hello_Spg_1";
end Hello_Spg_1;
subprogram Hello_Spg_2
properties
source_language => Ada95;
source_name => "Hello.Hello_Spg_2";
end Hello_Spg_2;
-------------
-- Threads --
-------------
thread Task
end Task;
thread implementation Task.impl_1
calls
MyCalls : {
P_Spg : subprogram Hello_Spg_1;
};
properties
Dispatch_Protocol => periodic;
Period => 1000ms;
Compute_Execution_time => 0 ms .. 3 ms;
Deadline => 1000 ms;
Source_Stack_Size => 13952 Bytes;
end Task.impl_1;
thread implementation Task.impl_2
calls
MyCall : {
P_Spg : subprogram Hello_Spg_2;
};
properties
Dispatch_Protocol => periodic;
Period => 500ms;
Compute_Execution_time => 0 ms .. 3 ms;
Deadline => 500 ms;
Source_Stack_Size => 13952 Bytes;
end Task.impl_2;
---------------
-- Processor --
---------------
processor cpurm
end cpurm;
processor implementation cpurm.impl
properties
Scheduling_Protocol => (Posix_1003_Highest_Priority_First_Protocol);
end cpurm.impl;
---------------
-- Processes --
---------------
process node_a
end node_a;
process implementation node_a.impl
subcomponents
Task1 : thread Task.impl_1;
Task2 : thread Task.impl_2;
annex real_specification {**
-- Tests references properties extraction
theorem test_reference_property
foreach cpu in processor_set do
var cos_x := cos (1.0);
var sin_x := sin (1.0);
var tan_x := tan (1.0);
var cosh_x := cosh (1.0);
var sinh_x := sinh (1.0);
var tanh_x := tanh (1.0);
var ln_x := ln (2.0);
var exp_x := exp (1.0);
var sqrt_x := sqrt (2.0);
check (1 = 1);
end test_reference_property;
**};
end node_a.impl;
------------
-- System --
------------
system rma