Commit 55e298c5 authored by yoogx's avatar yoogx
Browse files

* Remove PolyORB/Ada backend

parent 1c86364d
------------------------------------------------------------------------------
-- --
-- OCARINA COMPONENTS --
-- --
-- O C A R I N A . B A C K E N D S . P O _ Q O S _ A D A . H E L P E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2009 Telecom ParisTech, 2010-2012 ESA & ISAE. --
-- --
-- Ocarina is free software; you can redistribute it and/or modify --
-- it under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. Ocarina is distributed in the hope that it will be --
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with Ocarina; see file COPYING. --
-- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02111-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- Ocarina is maintained by the TASTE project --
-- (taste-users@lists.tuxfamily.org) --
-- --
------------------------------------------------------------------------------
with Namet;
with Utils; use Utils;
with Ocarina.ME_AADL;
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.ME_AADL.AADL_Instances.Nutils;
with Ocarina.ME_AADL.AADL_Instances.Entities;
with Ocarina.Backends.Utils;
with Ocarina.Backends.Properties;
with Ocarina.Backends.Messages;
with Ocarina.Backends.Ada_Tree.Nutils;
with Ocarina.Backends.Ada_Tree.Nodes;
with Ocarina.Backends.PO_QoS_Ada.Mapping;
with Ocarina.Backends.PO_QoS_Ada.Runtime;
with Ocarina.Backends.Ada_Values;
package body Ocarina.Backends.PO_QoS_Ada.Helpers is
use Namet;
use Ocarina.ME_AADL;
use Ocarina.ME_AADL.AADL_Instances.Nodes;
use Ocarina.ME_AADL.AADL_Instances.Entities;
use Ocarina.Backends.Utils;
use Ocarina.Backends.Properties;
use Ocarina.Backends.Messages;
use Ocarina.Backends.Ada_Tree.Nutils;
use Ocarina.Backends.PO_QoS_Ada.Mapping;
use Ocarina.Backends.PO_QoS_Ada.Runtime;
use Ocarina.Backends.Ada_Values;
package AAN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
package AAU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
package ADN renames Ocarina.Backends.Ada_Tree.Nodes;
------------------
-- Package_Spec --
------------------
package body Package_Spec is
procedure Visit_Architecture_Instance (E : Node_Id);
procedure Visit_Component_Instance (E : Node_Id);
procedure Visit_System_Instance (E : Node_Id);
procedure Visit_Process_Instance (E : Node_Id);
procedure Visit_Thread_Instance (E : Node_Id);
procedure Visit_Data_Instance (E : Node_Id);
procedure Visit_Subprogram_Instance (E : Node_Id);
function TypeCode_Declaration (E : Node_Id) return Node_Id;
-- Makes a TypeCode variable declaration corresponding to the
-- type definition node given as parameter
function From_Any_Spec (E : Node_Id) return Node_Id;
-- Makes a spec for the 'From_Any' function corresponding to
-- the type definition given as a parameter
function To_Any_Spec (E : Node_Id) return Node_Id;
-- Makes a spec for the 'To_Any' function corresponding to
-- the type definition given as a parameter
-----------
-- Visit --
-----------
procedure Visit (E : Node_Id) is
begin
case Kind (E) is
when K_Architecture_Instance =>
Visit_Architecture_Instance (E);
when K_Component_Instance =>
Visit_Component_Instance (E);
when others =>
null;
end case;
end Visit;
---------------------------------
-- Visit_Architecture_Instance --
---------------------------------
procedure Visit_Architecture_Instance (E : Node_Id) is
begin
Visit (Root_System (E));
end Visit_Architecture_Instance;
------------------------------
-- Visit_Component_Instance --
------------------------------
procedure Visit_Component_Instance (E : Node_Id) is
Category : constant Component_Category
:= Get_Category_Of_Component (E);
begin
case Category is
when CC_System =>
Visit_System_Instance (E);
when CC_Process =>
Visit_Process_Instance (E);
when CC_Thread =>
Visit_Thread_Instance (E);
when CC_Data =>
Visit_Data_Instance (E);
when CC_Subprogram =>
Visit_Subprogram_Instance (E);
when others =>
null;
end case;
end Visit_Component_Instance;
-------------------------
-- Visit_Data_Instance --
-------------------------
procedure Visit_Data_Instance (E : Node_Id) is
N : Node_Id;
S : Node_Id;
begin
-- Protected objects with accessors are not destined to
-- network transfert. They do not have helper routines.
if Get_Data_Representation (E) = Data_With_Accessors then
return;
end if;
-- Fixed point types are not supported yet
if Get_Data_Representation (E) = Data_Fixed
or else Get_Data_Representation (E) = Data_Array
then
Display_Located_Error
(AAN.Loc (E),
"Helper generation for this type not supported yet",
Fatal => True);
end if;
Set_Helpers_Spec;
if No (Get_Handling (E, By_Name, H_Ada_Helpers_Spec)) then
N := Message_Comment
("Data type "
& Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E)));
Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
-- For each data type definition, we generate the
-- following entities in the Helpers package spec:
-- 1) The TypeCode variable
N := TypeCode_Declaration (E);
Bind_AADL_To_TypeCode (Identifier (E), N);
Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
-- 2) The From_Any function spec
N := From_Any_Spec (E);
Bind_AADL_To_From_Any (Identifier (E), N);
Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
-- 2) The To_Any function spec
N := To_Any_Spec (E);
Bind_AADL_To_To_Any (Identifier (E), N);
Append_Node_To_List (N, ADN.Visible_Part (Current_Package));
Set_Handling (E, By_Name, H_Ada_Helpers_Spec, E);
-- Visit the subcomponents of E (if any)
if not AAU.Is_Empty (Subcomponents (E)) then
S := First_Node (Subcomponents (E));
while Present (S) loop
Visit (Corresponding_Instance (S));
S := Next_Node (S);
end loop;
end if;
else
-- This type has already been handled, take the bindings
-- correspodning to the first handled instance
Bind_AADL_To_TypeCode
(Identifier (E),
ADN.TypeCode_Node
(Backend_Node
(Identifier
(Get_Handling
(E,
By_Name,
H_Ada_Helpers_Spec)))));
Bind_AADL_To_From_Any
(Identifier (E),
ADN.From_Any_Node
(Backend_Node
(Identifier
(Get_Handling
(E,
By_Name,
H_Ada_Helpers_Spec)))));
Bind_AADL_To_To_Any
(Identifier (E),
ADN.To_Any_Node
(Backend_Node
(Identifier
(Get_Handling
(E,
By_Name,
H_Ada_Helpers_Spec)))));
end if;
end Visit_Data_Instance;
----------------------------
-- Visit_Process_Instance --
----------------------------
procedure Visit_Process_Instance (E : Node_Id) is
U : constant Node_Id := ADN.Distributed_Application_Unit
(ADN.Helpers_Node (Backend_Node (Identifier (E))));
P : constant Node_Id := ADN.Entity (U);
S : Node_Id;
begin
Push_Entity (P);
Push_Entity (U);
-- Start recording all handlings because we want to reset
-- them for each node.
Start_Recording_Handlings;
-- Visit recursively all the subcomponents of the process
if not AAU.Is_Empty (Subcomponents (E)) then
S := First_Node (Subcomponents (E));
while Present (S) loop
-- Visit the corresponding component instance
Visit (Corresponding_Instance (S));
S := Next_Node (S);
end loop;
end if;
-- Reset all the recorded handlings
Reset_Handlings;
Pop_Entity; -- U
Pop_Entity; -- P
end Visit_Process_Instance;
-------------------------------
-- Visit_Subprogram_Instance --
-------------------------------
procedure Visit_Subprogram_Instance (E : Node_Id) is
F : Node_Id;
Call_Seq : Node_Id;
Spg_Call : Node_Id;
begin
-- Visit all data types
if not AAU.Is_Empty (Features (E)) then
F := First_Node (Features (E));
while Present (F) loop
if Present (Corresponding_Instance (F)) then
Visit (Corresponding_Instance (F));
end if;
F := Next_Node (F);
end loop;
end if;
-- Visit all the call sequences of the subprogram
if not AAU.Is_Empty (Calls (E)) then
Call_Seq := First_Node (Calls (E));
while Present (Call_Seq) loop
-- For each call sequence visit all the called
-- subprograms.
if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
while Present (Spg_Call) loop
Visit (Corresponding_Instance (Spg_Call));
Spg_Call := Next_Node (Spg_Call);
end loop;
end if;
Call_Seq := Next_Node (Call_Seq);
end loop;
end if;
end Visit_Subprogram_Instance;
---------------------------
-- Visit_System_Instance --
---------------------------
procedure Visit_System_Instance (E : Node_Id) is
S : Node_Id;
begin
Push_Entity (Ada_Root);
if not AAU.Is_Empty (Subcomponents (E)) then
S := First_Node (Subcomponents (E));
while Present (S) loop
-- Visit the corresponding component instance
Visit (Corresponding_Instance (S));
S := Next_Node (S);
end loop;
end if;
Pop_Entity; -- Ada_Root
end Visit_System_Instance;
---------------------------
-- Visit_Thread_Instance --
---------------------------
procedure Visit_Thread_Instance (E : Node_Id) is
Call_Seq : Node_Id;
Spg_Call : Node_Id;
F : Node_Id;
begin
-- Visit all the thread features
if not AAU.Is_Empty (Features (E)) then
F := First_Node (Features (E));
while Present (F) loop
if Kind (F) = K_Port_Spec_Instance
and then AAN.Is_Data (F)
then
Visit (Corresponding_Instance (F));
end if;
F := Next_Node (F);
end loop;
end if;
-- Visit all the call sequences of the thread
if not AAU.Is_Empty (Calls (E)) then
Call_Seq := First_Node (Calls (E));
while Present (Call_Seq) loop
-- For each call sequence visit all the called
-- subprograms.
if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
while Present (Spg_Call) loop
Visit (Corresponding_Instance (Spg_Call));
Spg_Call := Next_Node (Spg_Call);
end loop;
end if;
Call_Seq := Next_Node (Call_Seq);
end loop;
end if;
end Visit_Thread_Instance;
--------------------------
-- TypeCode_Declaration --
--------------------------
function TypeCode_Declaration (E : Node_Id) return Node_Id is
V_Identifier : Node_Id;
N : Node_Id;
begin
pragma Assert (AAU.Is_Data (E));
V_Identifier := Map_TC_Variable_Identifier (E);
N := Make_Object_Declaration
(Defining_Identifier => V_Identifier,
Object_Definition => RE (RE_Object_Ptr));
return N;
end TypeCode_Declaration;
-------------------
-- From_Any_Spec --
-------------------
function From_Any_Spec (E : Node_Id) return Node_Id is
Return_Type : Node_Id;
N : Node_Id;
begin
pragma Assert (AAU.Is_Data (E));
-- Get the Ada type that was mapped from E
Return_Type := Map_Ada_Data_Type_Designator (E);
N := Make_Subprogram_Specification
(Defining_Identifier => Make_Defining_Identifier
(SN (S_From_Any)),
Parameter_Profile => Make_List_Id
(Make_Parameter_Specification
(Make_Defining_Identifier (PN (P_Item)),
RE (RE_Any))),
Return_Type => Return_Type);
return N;
end From_Any_Spec;
-----------------
-- To_Any_Spec --
-----------------
function To_Any_Spec (E : Node_Id) return Node_Id is
Item_Type : Node_Id;
N : Node_Id;
begin
pragma Assert (AAU.Is_Data (E));
-- Get the Ada type that was mapped from E
Item_Type := Map_Ada_Data_Type_Designator (E);
N := Make_Subprogram_Specification
(Defining_Identifier => Make_Defining_Identifier
(SN (S_To_Any)),
Parameter_Profile => Make_List_Id
(Make_Parameter_Specification
(Make_Defining_Identifier (PN (P_Item)),
Item_Type)),
Return_Type => RE (RE_Any));
return N;
end To_Any_Spec;
end Package_Spec;
------------------
-- Package_Body --
------------------
package body Package_Body is
procedure Visit_Architecture_Instance (E : Node_Id);
procedure Visit_Component_Instance (E : Node_Id);
procedure Visit_System_Instance (E : Node_Id);
procedure Visit_Process_Instance (E : Node_Id);
procedure Visit_Thread_Instance (E : Node_Id);
procedure Visit_Data_Instance (E : Node_Id);
procedure Visit_Subprogram_Instance (E : Node_Id);
function From_Any_Body (E : Node_Id) return Node_Id;
-- Makes the body of the From_Any function corresponding to the
-- data type E
function To_Any_Body (E : Node_Id) return Node_Id;
-- Makes the body of the To_Any function corresponding to the
-- data type E
Initialization_Specs : List_Id;
-- Contains the spec and the flags of the initilization
-- routines of all data types
Initialization_Bodies : List_Id;
-- Contains the bodies of the initilization routines of all
-- data types
function Initialization_Flag_Declaration (E : Node_Id) return Node_Id;
-- Makes the declaration of the boolean flag that indicates
-- wether the type E is already initialized or not
function Initialize_Spec (E : Node_Id) return Node_Id;
-- Makes the spec of the Initialize_<Data_Type_Name> procedure
function Initialize_Body (E : Node_Id) return Node_Id;
-- Makes the body of the Initialize_<Data_Type_Name> procedure
function Deferred_Initialization_Spec return Node_Id;
-- Makes the Spec of the deferred initialization procedure
function Deferred_Initialization_Body return Node_Id;
-- Makes the body of the deferred initialization procedure
function Helper_Initialization return Node_Id;
-- Makes the package initialization routine (which is called at
-- the eleboration
-----------
-- Visit --
-----------
procedure Visit (E : Node_Id) is
begin
case Kind (E) is
when K_Architecture_Instance =>
Visit_Architecture_Instance (E);
when K_Component_Instance =>
Visit_Component_Instance (E);
when others =>
null;
end case;
end Visit;
---------------------------------
-- Visit_Architecture_Instance --
---------------------------------
procedure Visit_Architecture_Instance (E : Node_Id) is
begin
Visit (Root_System (E));
end Visit_Architecture_Instance;
------------------------------
-- Visit_Component_Instance --
------------------------------
procedure Visit_Component_Instance (E : Node_Id) is
Category : constant Component_Category
:= Get_Category_Of_Component (E);
begin
case Category is
when CC_System =>
Visit_System_Instance (E);
when CC_Process =>
Visit_Process_Instance (E);
when CC_Thread =>
Visit_Thread_Instance (E);
when CC_Data =>
Visit_Data_Instance (E);
when CC_Subprogram =>
Visit_Subprogram_Instance (E);
when others =>
null;
end case;
end Visit_Component_Instance;
-------------------------
-- Visit_Data_Instance --
-------------------------
procedure Visit_Data_Instance (E : Node_Id) is
N : Node_Id;
S : Node_Id;
begin
-- Protected objects with accessors are not destined to
-- network transfert. They do not have helper routines.
if Get_Data_Representation (E) = Data_With_Accessors then
return;
end if;