------------------------------------------------------------------------------
-- --
-- OCARINA COMPONENTS --
-- --
-- O C A R I N A . B A C K E N D S . U T I L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2010, GET-Telecom Paris. --
-- --
-- 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 Ocarina team --
-- (ocarina-users@listes.enst.fr) --
-- --
------------------------------------------------------------------------------
with GNAT.OS_Lib;
with GNAT.Directory_Operations;
with GNAT.Table;
with Namet;
with Locations;
with Ocarina.ME_AADL;
with Ocarina.ME_AADL.AADL_Tree.Nodes;
with Ocarina.ME_AADL.AADL_Tree.Nutils;
with Ocarina.ME_AADL.AADL_Tree.Entities.Properties;
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.ME_AADL.AADL_Instances.Nutils;
with Ocarina.ME_AADL.AADL_Instances.Entities;
with Ocarina.Backends.Messages;
with Ocarina.Backends.Ada_Tree.Nodes;
with Ocarina.Backends.Ada_Tree.Nutils;
with Ocarina.Backends.Ada_Values;
package body Ocarina.Backends.Utils is
package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
package ATU renames Ocarina.ME_AADL.AADL_Tree.Nutils;
package AIN 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 ADU renames Ocarina.Backends.Ada_Tree.Nutils;
package ADV renames Ocarina.Backends.Ada_Values;
use GNAT.OS_Lib;
use GNAT.Directory_Operations;
use Namet;
use Locations;
use Ocarina.ME_AADL;
use Ocarina.ME_AADL.AADL_Instances.Nodes;
use Ocarina.ME_AADL.AADL_Instances.Nutils;
use Ocarina.ME_AADL.AADL_Instances.Entities;
use Ocarina.Backends.Messages;
use Ocarina.Backends.Ada_Tree.Nutils;
-- The entered directories stack
package Directories_Stack is new GNAT.Table
(Name_Id, Int, 1, 5, 10);
function Get_Handling_Internal_Name
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind)
return Name_Id;
-- Code factorisation between Set_Handling and Get_Handling. This
-- function computes an internal name used to store the handling
-- information.
function Map_Ada_Subprogram_Status_Name (S : Node_Id) return Name_Id;
-- Maps an name for the record type corresponding to a hybrid
-- subprogram.
function Map_Ada_Call_Seq_Access_Name (S : Node_Id) return Name_Id;
-- Maps an name for the subprogram access type corresponding to a
-- hybrid subprogram.
function Map_Ada_Call_Seq_Subprogram_Name
(Spg : Node_Id;
Seq : Node_Id)
return Name_Id;
-- Maps an name for the subprogram corresponding to a hybrid
-- subprogram call sequence.
type Repository_Entry is record
E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind;
A : Node_Id;
end record;
-- One entry of the internal handling repository
Recording_Requested : Boolean := False;
package Handling_Repository is new GNAT.Table
(Repository_Entry, Int, 1, 5, 10);
-- The internal handling repository
procedure May_Be_Append_Handling_Entry
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind;
A : Node_Id);
-- Add a new entry corresponding to the given parameters to the
-- internal handling repository. The addition is only done in case
-- the user requested explicitely the recording of handling
function Bind_Transport_API_Internal_Name (P : Node_Id) return Name_Id;
-- For code factorization purpose
----------------------
-- Create_Directory --
----------------------
procedure Create_Directory (Dir_Full_Name : Name_Id) is
Dir_Full_String : constant String := Get_Name_String (Dir_Full_Name);
begin
if Is_Regular_File (Dir_Full_String)
or else Is_Symbolic_Link (Dir_Full_String)
then
Display_Error
("Cannot create "
& Dir_Full_String
& " because there is a file with the same name",
Fatal => True);
return;
end if;
if Is_Directory (Dir_Full_String) then
if Dir_Full_String /= "." then
Display_Error
(Dir_Full_String
& " already exists",
Fatal => False,
Warning => True);
end if;
return;
end if;
-- The directory name does not clash with anything, create it
Make_Dir (Dir_Full_String);
end Create_Directory;
---------------------
-- Enter_Directory --
---------------------
procedure Enter_Directory (Dirname : Name_Id) is
use Directories_Stack;
Current_Directory : constant Name_Id :=
Get_String_Name (Get_Current_Dir);
begin
Increment_Last;
Table (Last) := Current_Directory;
Display_Debug_Message
("Left : " & Get_Name_String (Current_Directory));
Change_Dir (Get_Name_String (Dirname));
Display_Debug_Message ("Entered : " & Get_Name_String (Dirname));
end Enter_Directory;
---------------------
-- Leave_Directory --
---------------------
procedure Leave_Directory is
use Directories_Stack;
Last_Directory : constant Name_Id :=
Table (Last);
begin
Decrement_Last;
Display_Debug_Message ("Left : " & Get_Current_Dir);
Change_Dir (Get_Name_String (Last_Directory));
Display_Debug_Message ("Entered : " & Get_Name_String (Last_Directory));
end Leave_Directory;
-----------------------------
-- Add_Directory_Separator --
-----------------------------
function Add_Directory_Separator (Path : Name_Id) return Name_Id is
begin
Get_Name_String (Path);
if Name_Buffer (Name_Len) /= Directory_Separator then
Add_Char_To_Name_Buffer (Directory_Separator);
end if;
return Name_Find;
end Add_Directory_Separator;
--------------------------------
-- Remove_Directory_Separator --
--------------------------------
function Remove_Directory_Separator (Path : Name_Id) return Name_Id is
begin
Get_Name_String (Path);
if Name_Buffer (Name_Len) = Directory_Separator then
Name_Len := Name_Len - 1;
end if;
return Name_Find;
end Remove_Directory_Separator;
----------------------------------
-- May_Be_Append_Handling_Entry --
----------------------------------
procedure May_Be_Append_Handling_Entry
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind;
A : Node_Id)
is
package HR renames Handling_Repository;
The_Entry : constant Repository_Entry :=
Repository_Entry'(E => E,
Comparison => Comparison,
Handling => Handling,
A => A);
begin
if Recording_Requested then
HR.Increment_Last;
HR.Table (HR.Last) := The_Entry;
end if;
end May_Be_Append_Handling_Entry;
-------------------------------
-- Start_Recording_Handlings --
-------------------------------
procedure Start_Recording_Handlings is
begin
if Recording_Requested then
raise Program_Error with
"Consecutive calls to Start_Recording_Handlings are forbidden";
else
Recording_Requested := True;
end if;
end Start_Recording_Handlings;
------------------------------
-- Stop_Recording_Handlings --
------------------------------
procedure Stop_Recording_Handlings is
begin
Recording_Requested := False;
end Stop_Recording_Handlings;
---------------------
-- Reset_Handlings --
---------------------
procedure Reset_Handlings is
package HR renames Handling_Repository;
Index : Int := HR.First;
The_Entry : Repository_Entry;
begin
-- Disable the user handling request. It is important to do
-- this at the beginning to avoid adding new entries when
-- resetting.
Recording_Requested := False;
while Index <= HR.Last loop
The_Entry := HR.Table (Index);
-- Reset the handling information
Set_Handling
(The_Entry.E,
The_Entry.Comparison,
The_Entry.Handling,
No_Node);
Index := Index + 1;
end loop;
-- Deallocate and reinitialize the repository
HR.Free;
HR.Init;
end Reset_Handlings;
--------------------
-- Normalize_Name --
--------------------
function Normalize_Name (Name : Name_Id; Ada_Style : Boolean := False)
return Name_Id is
Normalized_Name : Name_Id;
begin
-- FIXME: The algorithm does not ensure a bijection between
-- the input and the output. It should be improved.
if Name = No_Name then
Normalized_Name := Name;
else
declare
Initial_Name : constant String := Get_Name_String (Name);
begin
Name_Len := 0;
for Index in Initial_Name'First .. Initial_Name'Last loop
if Initial_Name (Index) = '.' then
Add_Char_To_Name_Buffer ('_');
if Ada_Style then
Add_Char_To_Name_Buffer ('_');
end if;
elsif Initial_Name (Index) = '-' then
Add_Char_To_Name_Buffer ('_');
if Ada_Style then
Add_Char_To_Name_Buffer ('_');
end if;
else
Add_Char_To_Name_Buffer (Initial_Name (Index));
end if;
end loop;
Normalized_Name := Name_Find;
end;
end if;
return Normalized_Name;
end Normalize_Name;
------------------
-- Is_Namespace --
------------------
function Is_Namespace (N : Node_Id) return Boolean is
begin
return Kind (N) = K_Namespace_Instance;
end Is_Namespace;
----------------
-- Is_Delayed --
----------------
function Is_Delayed (E : Node_Id) return Boolean is
C : Node_Id;
S : Node_Id;
begin
pragma Assert
(Kind (E) = K_Port_Spec_Instance and then not Is_Event (E));
if not AAU.Is_Empty (Sources (E)) then
C := Extra_Item (First_Node (Sources (E)));
case AADL_Version is
when AADL_V1 =>
if ATN.Category (Corresponding_Declaration (C))
= Connection_Type'Pos (CT_Data_Delayed)
then
return True;
else
-- Recurse through the connection path
S := Item (First_Node (Sources (E)));
return S /= E and then
Kind (S) = K_Port_Spec_Instance and then
Is_Delayed (S);
end if;
when AADL_V2 =>
if Get_Port_Timing (E) = Port_Timing_Delayed then
return True;
else
-- Recurse through the connection path
S := Item (First_Node (Sources (E)));
return S /= E and then
Kind (S) = K_Port_Spec_Instance and then
Is_Delayed (S);
end if;
end case;
end if;
return False;
end Is_Delayed;
-----------------------
-- Has_In_Parameters --
-----------------------
function Has_In_Parameters (E : Node_Id) return Boolean is
F : Node_Id;
begin
if not AAU.Is_Empty (Features (E)) then
F := First_Node (Features (E));
while Present (F) loop
if Kind (F) = K_Parameter_Instance and then Is_In (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_In_Parameters;
------------------------
-- Has_Out_Parameters --
------------------------
function Has_Out_Parameters (E : Node_Id) return Boolean is
F : Node_Id;
begin
if not AAU.Is_Empty (Features (E)) then
F := First_Node (Features (E));
while Present (F) loop
if Kind (F) = K_Parameter_Instance and then Is_Out (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Out_Parameters;
------------------
-- Has_In_Ports --
------------------
function Has_In_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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 Is_In (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_In_Ports;
------------------------
-- Has_In_Event_Ports --
------------------------
function Has_In_Event_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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
Is_In (F) and then
Is_Event (F)
then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_In_Event_Ports;
-------------------
-- Has_Out_Ports --
-------------------
function Has_Out_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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 Is_Out (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Out_Ports;
-------------------------
-- Has_Out_Event_Ports --
-------------------------
function Has_Out_Event_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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
Is_Out (F) and then
Is_Event (F)
then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Out_Event_Ports;
---------------
-- Has_Ports --
---------------
function Has_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
if not AAU.Is_Empty (Features (E)) then
F := First_Node (Features (E));
while Present (F) loop
if Kind (F) = K_Port_Spec_Instance then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Ports;
----------------------
-- Has_Output_Ports --
----------------------
function Has_Output_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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
Is_Out (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Output_Ports;
---------------------
-- Has_Input_Ports --
---------------------
function Has_Input_Ports (E : Node_Id) return Boolean is
F : Node_Id;
begin
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
Is_In (F) then
return True;
end if;
F := Next_Node (F);
end loop;
end if;
return False;
end Has_Input_Ports;
---------------
-- Has_Modes --
---------------
function Has_Modes (E : Node_Id) return Boolean is
begin
pragma Assert (Kind (E) = K_Component_Instance);
return not AAU.Is_Empty (Modes (E));
end Has_Modes;
----------------------
-- Get_Source_Ports --
----------------------
function Get_Source_Ports (P : Node_Id) return List_Id is
function Rec_Get_Source_Ports
(P : Node_Id;
B : Node_Id := No_Node)
return List_Id;
-- Recursive internal routine
--------------------------
-- Rec_Get_Source_Ports --
--------------------------
function Rec_Get_Source_Ports
(P : Node_Id;
B : Node_Id := No_Node)
return List_Id
is
Result : constant List_Id := New_List (K_List_Id, No_Location);
C : Node_Id;
S : Node_Id;
Bus : Node_Id;
begin
if AAU.Is_Empty (Sources (P)) then
AAU.Append_Node_To_List
(Make_Node_Container (P, B), Result);
end if;
S := First_Node (Sources (P));
while Present (S) loop
if Kind (Item (S)) = K_Port_Spec_Instance
and then Parent_Component (Item (S)) /= No_Node
and then Is_Thread (Parent_Component (Item (S)))
then
-- We reached our end point, append it to the result list
AAU.Append_Node_To_List
(Make_Node_Container (Item (S), B), Result);
elsif Kind (Item (S)) = K_Port_Spec_Instance
and then Parent_Component (Item (S)) /= No_Node
and then (Is_Process_Or_Device (Parent_Component (Item (S))))
then
if Is_In (Item (S)) then
-- See whether the connection to the process is
-- bound to a bus.
C := Extra_Item (S);
if No (C) then
-- There has been definitly a bug while
-- expanding connections.
raise Program_Error with "Wrong expansion of connections";
end if;
-- Get the bus of the connection
Bus := Get_Bound_Bus (C, False);
else
Bus := No_Node;
end if;
if Present (B) and then Present (Bus) and then B /= Bus then
Display_Located_Error
(Loc (C),
"This connection is involved in a data flow"
& " mapped to several different buses",
Fatal => True);
end if;
-- Fetch recursively all the sources of S
AAU.Append_Node_To_List
(First_Node (Rec_Get_Source_Ports (Item (S), Bus)), Result);
else
Display_Located_Error
(Loc (P),
"This port has a source of a non supported kind",
Fatal => True);
end if;
S := Next_Node (S);
end loop;
return Result;
end Rec_Get_Source_Ports;
begin
if AAU.Is_Empty (Sources (P)) then
return No_List;
else
return Rec_Get_Source_Ports (P, No_Node);
end if;
end Get_Source_Ports;
---------------------------
-- Get_Destination_Ports --
---------------------------
function Get_Destination_Ports
(P : Node_Id;
Custom_Parent : Node_Id := No_Node) return List_Id is
function Rec_Get_Destination_Ports
(P : Node_Id;
B : Node_Id := No_Node;
Custom_Parent : Node_Id := No_Node)
return List_Id;
-- Recursive internal routine
-------------------------------
-- Rec_Get_Destination_Ports --
-------------------------------
function Rec_Get_Destination_Ports
(P : Node_Id;
B : Node_Id := No_Node;
Custom_Parent : Node_Id := No_Node)
return List_Id
is
Result : constant List_Id := New_List (K_List_Id, No_Location);
C : Node_Id;
D : Node_Id;
Bus : Node_Id;
begin
D := First_Node (Destinations (P));
while Present (D) loop
if Kind (Item (D)) = K_Port_Spec_Instance
and then Parent_Component (Item (D)) /= No_Node
and then Is_Thread (Parent_Component (Item (D)))
then
-- We reached our end point, append it to the result list
AAU.Append_Node_To_List
(Make_Node_Container (Item (D), B), Result);
elsif Kind (Item (D)) = K_Port_Spec_Instance
and then Parent_Component (Item (D)) /= No_Node
and then Is_Process (Parent_Component (Item (D)))
then
if Is_In (Item (D)) then
-- See whether the connection to the process is
-- bound to a bus.
C := Extra_Item (D);
if No (C) then
-- There has been definitly a bug while
-- expanding connections.
raise Program_Error with "Wrong expansion of connections";
end if;
-- Get the bus of the connection
Bus := Get_Bound_Bus (C, False);
else
Bus := No_Node;
end if;
if Present (B) and then Present (Bus) and then B /= Bus then
Display_Located_Error
(Loc (C),
"This connection is involved in a data flow"
& " mapped to several different buses",
Fatal => True);
end if;
-- Fetch recursively all the destinations of D
AAU.Append_Node_To_List
(First_Node
(Rec_Get_Destination_Ports (Item (D), Bus)), Result);
elsif Kind (Item (D)) = K_Port_Spec_Instance
and then Parent_Component (Item (D)) /= No_Node
and then Is_Device (Parent_Component (Item (D)))
then
-- We reached our end point, append it to the result list
AAU.Append_Node_To_List
(Make_Node_Container (Item (D), B), Result);
elsif Custom_Parent /= No_Node and then
Is_Device (Custom_Parent) and then
Get_Port_By_Name (P, Custom_Parent) /= No_Node then
AAU.Append_Node_To_List
(First_Node
(Rec_Get_Destination_Ports
(Get_Port_By_Name (P, Custom_Parent),
B,
No_Node)),
Result);
else
Display_Located_Error
(Loc (P),
"This port has a destination of a non supported kind",
Fatal => True);
end if;
D := Next_Node (D);
end loop;
return Result;
end Rec_Get_Destination_Ports;
begin
return Rec_Get_Destination_Ports (P, No_Node, Custom_Parent);
end Get_Destination_Ports;
----------------------
-- Get_Actual_Owner --
----------------------
function Get_Actual_Owner (Spg_Call : Node_Id) return Node_Id is
Spg : constant Node_Id := Corresponding_Instance (Spg_Call);
Data_Component : Node_Id;
F : Node_Id;
begin
-- If the subprogram call is not a method return No_Node
if AAU.Is_Empty (Path (Spg_Call)) then
return No_Node;
end if;
Data_Component := Item (First_Node (Path (Spg_Call)));
-- Traverse all the required access of the subprogram instance
-- and find the one corresponding to the owner data component.
if not AAU.Is_Empty (Features (Spg)) then
F := First_Node (Features (Spg));
while Present (F) loop
if Kind (F) = K_Subcomponent_Access_Instance then
-- FIXME: We stop at the first met feature that
-- corresponds to our criteria.
-- The corresponding declaration of Data_Component is
-- always a component type and not a component
-- implementation. However the type of the feature F
-- may be a component type as well as a component
-- implementation. We test both cases.
declare
Dcl_Data_Component : constant Node_Id :=
Corresponding_Declaration (Data_Component);
Dcl_F : constant Node_Id :=
Corresponding_Declaration (Corresponding_Instance (F));
use Ocarina.ME_AADL.AADL_Tree.Nodes;
begin
exit when
(ATN.Kind (Dcl_F) = K_Component_Type and then
Dcl_F = Dcl_Data_Component)
or else
(ATN.Kind (Dcl_F) = K_Component_Implementation and then
ATN.Corresponding_Entity
(ATN.Component_Type_Identifier
(Dcl_F)) = Dcl_Data_Component);
end;
end if;
F := Next_Node (F);
end loop;
end if;
-- If no feature matched, raise an error
if AAU.Is_Empty (Features (Spg)) or else No (F) then
Display_Located_Error
(Loc (Spg),
"Feature subprogram has not access to its owner component",
Fatal => True);
end if;
return Get_Subcomponent_Access_Source (F);
end Get_Actual_Owner;
---------------------------
-- Get_Container_Process --
---------------------------
function Get_Container_Process (E : Node_Id) return Node_Id is
begin
pragma Assert (Present (E));
case Kind (E) is
when K_Call_Instance =>
return Get_Container_Process (Parent_Sequence (E));
when K_Call_Sequence_Instance | K_Subcomponent_Instance =>
return Get_Container_Process (Parent_Component (E));
when others =>
if Is_Thread (E) or else Is_Subprogram (E) then
return Get_Container_Process (Parent_Subcomponent (E));
elsif Is_Process (E) or else Is_Device (E) then
return Parent_Subcomponent (E);
else
raise Program_Error with "Wrong node kind in "
& "Get_Container_Process: " & Kind (E)'Img
& " " & Get_Category_Of_Component (E)'Img;
end if;
end case;
end Get_Container_Process;
--------------------------
-- Get_Container_Thread --
--------------------------
function Get_Container_Thread (E : Node_Id) return Node_Id is
begin
case Kind (E) is
when K_Call_Instance =>
return Get_Container_Thread (Parent_Sequence (E));
when K_Call_Sequence_Instance =>
return Parent_Component (E);
when others =>
if Is_Subprogram (E) then
return Get_Container_Thread (Parent_Subcomponent (E));
else
raise Program_Error with "Wrong node kind in "
& "Get_Container_Thread: " & Kind (E)'Img;
end if;
end case;
end Get_Container_Thread;
--------------------------------
-- Get_Handling_Internal_Name --
--------------------------------
function Get_Handling_Internal_Name
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind)
return Name_Id
is
begin
case Comparison is
when By_Name =>
Get_Name_String (Map_Ada_Defining_Identifier (E));
-- Get_Name_String (Compute_Full_Name_Of_Instance (E));
when By_Node =>
Set_Nat_To_Name_Buffer (Nat (E));
end case;
Add_Str_To_Name_Buffer ("%Handling%" & Handling'Img);
return Name_Find;
end Get_Handling_Internal_Name;
------------------
-- Set_Handling --
------------------
procedure Set_Handling
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind;
A : Node_Id)
is
Internal_Name : constant Name_Id := Get_Handling_Internal_Name
(E, Comparison, Handling);
begin
Set_Name_Table_Info (Internal_Name, Nat (A));
May_Be_Append_Handling_Entry (E, Comparison, Handling, A);
end Set_Handling;
------------------
-- Get_Handling --
------------------
function Get_Handling
(E : Node_Id;
Comparison : Comparison_Kind;
Handling : Handling_Kind)
return Node_Id
is
Internal_Name : constant Name_Id := Get_Handling_Internal_Name
(E, Comparison, Handling);
begin
return Node_Id (Get_Name_Table_Info (Internal_Name));
end Get_Handling;
--------------------
-- Bind_Two_Nodes --
--------------------
function Bind_Two_Nodes (N_1 : Node_Id; N_2 : Node_Id) return Node_Id is
function Get_Binding_Internal_Name
(N_1 : Node_Id;
N_2 : Node_Id)
return Name_Id;
-- Return an internal name id useful for the binding
-------------------------------
-- Get_Binding_Internal_Name --
-------------------------------
function Get_Binding_Internal_Name
(N_1 : Node_Id;
N_2 : Node_Id)
return Name_Id
is
begin
Set_Nat_To_Name_Buffer (Nat (N_1));
Add_Str_To_Name_Buffer ("%Binding%");
Add_Nat_To_Name_Buffer (Nat (N_2));
return Name_Find;
end Get_Binding_Internal_Name;
I_Name : constant Name_Id := Get_Binding_Internal_Name (N_1, N_2);
N : Node_Id;
begin
-- If the Bind_Two_Nodes has already been called on N_1 and
-- N_1, return the result of the first call.
if Get_Name_Table_Info (I_Name) /= 0 then
return Node_Id (Get_Name_Table_Info (I_Name));
end if;
-- Otherwise, create a new binding node
N := Make_Identifier
(No_Location, No_Name, No_Name, No_Node);
Set_Name_Table_Info (I_Name, Int (N));
return N;
end Bind_Two_Nodes;
--------------------------------------
-- Bind_Transport_API_Internal_Name --
--------------------------------------
function Bind_Transport_API_Internal_Name (P : Node_Id) return Name_Id is
begin
pragma Assert (Is_Process (P));
Set_Nat_To_Name_Buffer (Nat (P));
Add_Str_To_Name_Buffer ("%transport%layer%binding%");
return Name_Find;
end Bind_Transport_API_Internal_Name;
------------------------
-- Bind_Transport_API --
------------------------
procedure Bind_Transport_API
(P : Node_Id;
T : Supported_Transport_APIs)
is
I_Name : constant Name_Id := Bind_Transport_API_Internal_Name (P);
begin
Set_Name_Table_Byte (I_Name, Supported_Transport_APIs'Pos (T));
end Bind_Transport_API;
-------------------------
-- Fetch_Transport_API --
-------------------------
function Fetch_Transport_API
(P : Node_Id)
return Supported_Transport_APIs
is
I_Name : constant Name_Id := Bind_Transport_API_Internal_Name (P);
begin
return Supported_Transport_APIs'Val (Get_Name_Table_Byte (I_Name));
end Fetch_Transport_API;
-------------------------------
-- Map_Ada_Full_Feature_Name --
-------------------------------
function Map_Ada_Full_Feature_Name
(E : Node_Id;
Suffix : Character := ASCII.NUL)
return Name_Id
is
begin
Get_Name_String (Compute_Full_Name_Of_Instance
(Instance => E,
Display_Name => True,
Keep_Root_System => False));
Get_Name_String (ADU.To_Ada_Name (Name_Find));
if Suffix /= ASCII.NUL then
Add_Str_To_Name_Buffer ('_' & Suffix);
end if;
return Name_Find;
end Map_Ada_Full_Feature_Name;
----------------------------------
-- Map_Ada_Data_Type_Designator --
----------------------------------
function Map_Ada_Data_Type_Designator (E : Node_Id) return Node_Id is
pragma Assert (AAU.Is_Data (E));
begin
return ADU.Extract_Designator
(ADN.Type_Definition_Node
(Backend_Node (Identifier (E))));
end Map_Ada_Data_Type_Designator;
---------------------------------
-- Map_Ada_Full_Parameter_Name --
---------------------------------
function Map_Ada_Full_Parameter_Name
(Spg : Node_Id;
P : Node_Id;
Suffix : Character := ASCII.NUL)
return Name_Id
is
begin
pragma Assert (Kind (P) = K_Parameter_Instance);
if Kind (Spg) = K_Component_Instance and then Is_Subprogram (Spg) then
Get_Name_String (Compute_Full_Name_Of_Instance (Spg, True));
elsif Kind (Spg) = K_Call_Instance then
Get_Name_String (Display_Name (Identifier (Spg)));
else
raise Program_Error with "Wrong subprogram kind";
end if;
Add_Char_To_Name_Buffer ('_');
Get_Name_String_And_Append (Display_Name (Identifier (P)));
-- Convert the name to a valid Ada identifier name
Get_Name_String (ADU.To_Ada_Name (Name_Find));
if Suffix /= ASCII.NUL then
Add_Str_To_Name_Buffer ('_' & Suffix);
end if;
return Name_Find;
end Map_Ada_Full_Parameter_Name;
-----------------------------
-- Map_Ada_Enumerator_Name --
-----------------------------
function Map_Ada_Enumerator_Name
(E : Node_Id;
Server : Boolean := False)
return Name_Id
is
Ada_Name_1 : Name_Id;
Ada_Name_2 : Name_Id;
begin
pragma Assert
(Is_Subprogram (E) or else Kind (E) = K_Subcomponent_Instance);
if Is_Subprogram (E)
or else Is_Process (Corresponding_Instance (E))
or else Is_Device (Corresponding_Instance (E))
then
-- For subprograms and processes, the enumerator name is
-- mapped from the entity name.
Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (E))));
Add_Str_To_Name_Buffer ("_K");
elsif Is_Thread (Corresponding_Instance (E)) then
-- For threads, the enumerator name is mapped from the
-- containing process or abstract component name and the
-- thread subcomponent name.
-- Verifiy that the thread is a subcomponent of a process,
-- or an abstract component (in the case of threads that
-- belong to a device driver).
pragma Assert (Is_Process (Parent_Component (E))
or else Is_Abstract (Parent_Component (E)));
if Is_Process (Parent_Component (E)) then
Ada_Name_1 := ADU.To_Ada_Name
(Display_Name
(Identifier
(Parent_Subcomponent
(Parent_Component (E)))));
elsif Is_Abstract (Parent_Component (E)) then
Ada_Name_1 := ADU.To_Ada_Name
(Display_Name (Identifier (Parent_Component (E))));
end if;
Ada_Name_2 := ADU.To_Ada_Name (Display_Name (Identifier (E)));
Get_Name_String (Ada_Name_1);
Add_Char_To_Name_Buffer ('_');
Get_Name_String_And_Append (Ada_Name_2);
Add_Str_To_Name_Buffer ("_K");
else
raise Program_Error with
"Wrong node kind for Map_Ada_Enumerator_Name " & Kind (E)'Img;
end if;
if Server then
Add_Str_To_Name_Buffer ("_Server");
end if;
return Name_Find;
end Map_Ada_Enumerator_Name;
---------------------------------
-- Map_Ada_Defining_Identifier --
---------------------------------
function Map_Ada_Defining_Identifier
(A : Node_Id;
Suffix : String := "")
return Name_Id
is
I : Node_Id := A;
N : Node_Id := No_Node;
J : Node_Id;
Name_List : List_Id;
begin
if Kind (A) /= K_Identifier then
I := Identifier (A);
end if;
if Kind (A) = K_Component_Instance then
N := Namespace (A);
elsif Kind (A) = K_Subcomponent_Instance then
if Present (Parent_Component (A)) then
N := Namespace (Parent_Component (A));
end if;
end if;
if N /= No_Node
and then Display_Name (Identifier (N)) /= No_Name
and then Get_Category_Of_Component (A) /= CC_Data
then
-- Use both namespace and identifier to build the Ada
-- defining identifier, to avoid collisions in the Ada
-- namespace.
-- XXX Note: we do not handle data component types for now,
-- as their mapping is unclear for now, see Code generation
-- annex for more details.
Name_List := AAU.Split_Name (N);
J := First_Node (Name_List);
if Present (J) then
Get_Name_String (To_Ada_Name (Display_Name (J)));
J := Next_Node (J);
while Present (J) loop
Add_Str_To_Name_Buffer ("_"
& Get_Name_String (Display_Name (J)));
J := Next_Node (J);
end loop;
end if;
Add_Str_To_Name_Buffer ("_" & Get_Name_String (Display_Name (I)));
else
Get_Name_String (To_Ada_Name (Display_Name (I)));
end if;
if Suffix /= "" then
Add_Str_To_Name_Buffer ("_" & Suffix);
end if;
return Name_Find;
end Map_Ada_Defining_Identifier;
function Map_Ada_Defining_Identifier
(A : Node_Id;
Suffix : String := "")
return Node_Id
is
begin
return Make_Defining_Identifier
(Map_Ada_Defining_Identifier (A, Suffix));
end Map_Ada_Defining_Identifier;
----------------------------
-- Map_Ada_Component_Name --
----------------------------
function Map_Ada_Component_Name (F : Node_Id) return Name_Id is
begin
Get_Name_String (To_Ada_Name (Display_Name (Identifier (F))));
Add_Str_To_Name_Buffer ("_DATA");
return Name_Find;
end Map_Ada_Component_Name;
--------------------------------------------
-- Map_Ada_Protected_Aggregate_Identifier --
--------------------------------------------
function Map_Ada_Protected_Aggregate_Identifier
(S : Node_Id;
A : Node_Id)
return Node_Id
is
S_Name : Name_Id;
A_Name : Name_Id;
begin
pragma Assert (Kind (S) = K_Subcomponent_Access_Instance and then
Kind (A) = K_Subcomponent_Instance);
S_Name := To_Ada_Name (Display_Name (Identifier (S)));
A_Name := To_Ada_Name (Display_Name (Identifier (A)));
Get_Name_String (S_Name);
Add_Char_To_Name_Buffer ('_');
Get_Name_String_And_Append (A_Name);
return Make_Defining_Identifier (Name_Find);
end Map_Ada_Protected_Aggregate_Identifier;
--------------------------------------
-- Map_Ada_Default_Value_Identifier --
--------------------------------------
function Map_Ada_Default_Value_Identifier (D : Node_Id) return Node_Id is
I : Node_Id;
begin
if Kind (D) /= K_Identifier then
I := Identifier (D);
end if;
Get_Name_String (To_Ada_Name (Display_Name (I)));
Add_Str_To_Name_Buffer ("_Default_Value");
return Make_Defining_Identifier (Name_Find);
end Map_Ada_Default_Value_Identifier;
--------------------------------
-- Map_Ada_Package_Identifier --
--------------------------------
function Map_Ada_Package_Identifier (E : Node_Id) return Node_Id is
Port_Name : Name_Id;
Thread_Name : Name_Id;
begin
pragma Assert
(AAU.Is_Data (E) or else Kind (E) = K_Port_Spec_Instance);
if AAU.Is_Data (E) then
Get_Name_String (To_Ada_Name (Display_Name (Identifier (E))));
else
Port_Name := To_Ada_Name (Display_Name (Identifier (E)));
Thread_Name := To_Ada_Name
(Display_Name
(Identifier
(Parent_Subcomponent
(Parent_Component
(E)))));
Get_Name_String (Thread_Name);
Add_Char_To_Name_Buffer ('_');
Get_Name_String_And_Append (Port_Name);
end if;
Add_Str_To_Name_Buffer ("_Pkg");
return Make_Defining_Identifier (Name_Find);
end Map_Ada_Package_Identifier;
-----------------------------------
-- Map_Ada_Subprogram_Identifier --
-----------------------------------
function Map_Ada_Subprogram_Identifier (E : Node_Id) return Node_Id is
Spg_Name : Name_Id;
begin
pragma Assert (Is_Thread (E) or else
Is_Subprogram (E) or else
Kind (E) = K_Port_Spec_Instance);
if Is_Subprogram (E)
and then Get_Source_Language (E) /= Language_Ada_95
then
Display_Located_Error
(Loc (E),
"This is not an Ada subprogram", Fatal => True);
end if;
-- Get the subprogram name
if Is_Subprogram (E) then
Spg_Name := Get_Source_Name (E);
elsif Is_Thread (E) then
Spg_Name := Get_Thread_Compute_Entrypoint (E);
else
Spg_Name := Get_Port_Compute_Entrypoint (E);
end if;
return Map_Ada_Subprogram_Identifier (Spg_Name);
end Map_Ada_Subprogram_Identifier;
-----------------------------------
-- Map_Ada_Subprogram_Identifier --
-----------------------------------
function Map_Ada_Subprogram_Identifier (N : Name_Id) return Node_Id is
P_Name : Name_Id;
Result : Node_Id;
D : Node_Id;
begin
-- Get the package implementation and add the 'with' clause
P_Name := Unit_Name (N);
if P_Name = No_Name then
Display_Error
("You must give the subprogram implementation name", Fatal => True);
end if;
D := Make_Designator (P_Name);
ADN.Set_Corresponding_Node
(ADN.Defining_Identifier (D), New_Node (ADN.K_Package_Specification));
Add_With_Package (D);
-- Get the full implementation name
Get_Name_String (Local_Name (N));
Result := Make_Defining_Identifier (Name_Find);
Set_Homogeneous_Parent_Unit_Name (Result, D);
return Result;
end Map_Ada_Subprogram_Identifier;
-----------------------------
-- Map_Ada_Subprogram_Spec --
-----------------------------
function Map_Ada_Subprogram_Spec (S : Node_Id) return Node_Id is
Profile : constant List_Id := ADU.New_List (ADN.K_Parameter_Profile);
Param : Node_Id;
Mode : Mode_Id;
F : Node_Id;
N : Node_Id;
D : Node_Id;
Field : Node_Id;
begin
pragma Assert (Is_Subprogram (S));
-- We build the parameter profile of the subprogram instance by
-- adding:
-- First, the parameter features mapping
if not AAU.Is_Empty (Features (S)) then
F := First_Node (Features (S));
while Present (F) loop
if Kind (F) = K_Parameter_Instance then
if Is_In (F) and then Is_Out (F) then
Mode := Mode_Inout;
elsif Is_Out (F) then
Mode := Mode_Out;
elsif Is_In (F) then
Mode := Mode_In;
else
Display_Located_Error
(Loc (F),
"Unspecified parameter mode",
Fatal => True);
end if;
D := Corresponding_Instance (F);
Param := ADU.Make_Parameter_Specification
(Map_Ada_Defining_Identifier (F),
Map_Ada_Data_Type_Designator (D),
Mode);
ADU.Append_Node_To_List (Param, Profile);
end if;
F := Next_Node (F);
end loop;
end if;
-- Second, the data access mapping. The data accesses are not
-- mapped in the case of pure call sequence subprogram because
-- they are used only to close the access chain.
if Get_Subprogram_Kind (S) /= Subprogram_Pure_Call_Sequence then
if not AAU.Is_Empty (Features (S)) then
F := First_Node (Features (S));
while Present (F) loop
if Kind (F) = K_Subcomponent_Access_Instance then
case Get_Required_Data_Access (Corresponding_Instance (F)) is
when Access_Read_Only =>
Mode := Mode_In;
when Access_Write_Only =>
Mode := Mode_Out;
when Access_Read_Write =>
Mode := Mode_Inout;
when Access_None =>
-- By default, we allow read/write access
Mode := Mode_Inout;
when others =>
Display_Located_Error
(Loc (F),
"Unsupported required access",
Fatal => True);
end case;
D := Corresponding_Instance (F);
case Get_Data_Representation (D) is
when Data_Integer
| Data_Boolean
| Data_Float
| Data_Fixed
| Data_String
| Data_Wide_String
| Data_Character
| Data_Wide_Character
| Data_Array =>
-- If the data component is a simple data
-- component (not a structure), we simply add a
-- parameter with the computed mode and with a
-- type mapped from the data component.
Param := ADU.Make_Parameter_Specification
(Map_Ada_Defining_Identifier (F),
Map_Ada_Data_Type_Designator (D),
Mode);
ADU.Append_Node_To_List (Param, Profile);
when Data_Struct | Data_With_Accessors =>
-- If the data component is a complex data
-- component (which has subcomponents), we add a
-- parameter with the computed mode and with a
-- type mapped from each subcomponent type.
Field := First_Node (Subcomponents (D));
while Present (Field) loop
-- The parameter name is mapped from the
-- container data component and the data
-- subcomponent.
if AAU.Is_Data (Corresponding_Instance (Field)) then
Param := ADU.Make_Parameter_Specification
(Map_Ada_Protected_Aggregate_Identifier
(F, Field),
Map_Ada_Data_Type_Designator
(Corresponding_Instance (Field)),
Mode);
ADU.Append_Node_To_List (Param, Profile);
end if;
Field := Next_Node (Field);
end loop;
when others =>
Display_Located_Error
(Loc (F),
"Unsupported data type",
Fatal => True);
end case;
end if;
F := Next_Node (F);
end loop;
end if;
end if;
-- Last, if the subprogram has OUT ports, we add an additional
-- Status parameter.
if Has_Out_Ports (S) then
Param := ADU.Make_Parameter_Specification
(Make_Defining_Identifier (PN (P_Status)),
Extract_Designator
(ADN.Type_Definition_Node
(Backend_Node
(Identifier (S)))),
Mode_Inout);
ADU.Append_Node_To_List (Param, Profile);
end if;
N := ADU.Make_Subprogram_Specification
(Map_Ada_Defining_Identifier (S),
Profile,
No_Node);
-- If the program is an Opaque_C, we add the pragma Import
-- instruction in the private part of the current package
if Get_Subprogram_Kind (S) = Subprogram_Opaque_C then
declare
use ADN;
P : constant Node_Id := Make_Pragma_Statement
(Pragma_Import,
Make_List_Id
(Make_Defining_Identifier (PN (P_C)),
Map_Ada_Defining_Identifier (S),
Make_Literal
(ADV.New_String_Value (Get_Source_Name (S)))));
begin
-- We must ensure that we are inside the scope of a
-- package spec before inserting the pragma. In fact,
-- Map_Ada_Subprogram_Spec is called also when we build
-- the body of the subprogram, and we do not want to
-- insert the pragma when building the body.
if ADN.Kind (Current_Package) = K_Package_Specification then
ADU.Append_Node_To_List (P, Private_Part (Current_Package));
end if;
end;
end if;
return N;
end Map_Ada_Subprogram_Spec;
-----------------------------
-- Map_Ada_Subprogram_Body --
-----------------------------
function Map_Ada_Subprogram_Body (S : Node_Id) return Node_Id is
Spec : constant Node_Id := Map_Ada_Subprogram_Spec (S);
Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
Statements : constant List_Id := New_List (ADN.K_Statement_List);
Profile : List_Id;
N : Node_Id;
F : Node_Id;
Call_Seq : Node_Id;
begin
case Get_Subprogram_Kind (S) is
when Subprogram_Empty =>
-- An empty AADL subprogram is mapped into an Ada
-- subprogram that raises an exception to warn the user.
N := Make_Exception_Declaration
(Make_Defining_Identifier
(EN (E_NYI)));
ADU.Append_Node_To_List (N, Declarations);
N := Make_Raise_Statement (Make_Defining_Identifier (EN (E_NYI)));
ADU.Append_Node_To_List (N, Statements);
return Make_Subprogram_Implementation
(Spec, Declarations, Statements);
when Subprogram_Opaque_C =>
-- An opaque C AADL subprogram is a subprogram which is
-- implemented by a C subprogram. We perform the mapping
-- between the two subprograms using the Ada `Import'
-- pragma in the specification. Therefore, we have
-- nothing to do in the body.
return No_Node;
when Subprogram_Opaque_Ada_95 =>
-- An opaque Ada AADL subprogram is a subprogram which is
-- implemented by an Ada subprogram. We perform the
-- mapping between the two subprograms using the Ada
-- renaming facility.
-- Add the proper `with' clause
N := Make_Designator (Unit_Name (Get_Source_Name (S)));
Add_With_Package (N);
-- Perform the renaming
N := Make_Designator
(Local_Name (Get_Source_Name (S)),
Unit_Name (Get_Source_Name (S)));
ADN.Set_Renamed_Entity (Spec, N);
return Spec;
when Subprogram_Opaque_Ada_95_Transfo =>
-- Same as above, but does not with the package, because
-- it is actually an instanciated generic package
-- Perform the renaming
N := Make_Designator
(Local_Name (Get_Transfo_Source_Name (S)),
Unit_Name (Get_Transfo_Source_Name (S)));
ADN.Set_Renamed_Entity (Spec, N);
return Spec;
when Subprogram_Pure_Call_Sequence =>
-- A pure call sequence subprogram is a subprogram that
-- has exactly one call sequence. The behaviour of this
-- subprogram is simply the call to the subprograms
-- present in its call list.
Handle_Call_Sequence
(S,
Make_Defining_Identifier (PN (P_Status)),
First_Node (Calls (S)),
Declarations,
Statements);
return ADU.Make_Subprogram_Implementation
(Spec, Declarations, Statements);
when Subprogram_Hybrid_Ada_95 =>
-- Hybrid subprograms are subprograms that contain more
-- that one call sequence.
-- Declare the Status local variable
N := Make_Object_Declaration
(Defining_Identifier => Make_Defining_Identifier (PN (P_Status)),
Object_Definition => Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (S)));
ADU.Append_Node_To_List (N, Declarations);
-- Initialise the record fields that correspond to IN
-- parameters.
if not AAU.Is_Empty (Features (S)) then
F := First_Node (Features (S));
while Present (F) loop
if Kind (F) = K_Parameter_Instance and then Is_In (F) then
N := Make_Assignment_Statement
(Make_Designator
(To_Ada_Name (Display_Name (Identifier (F))),
PN (P_Status)),
Make_Designator
(To_Ada_Name (Display_Name (Identifier (F)))));
ADU.Append_Node_To_List (N, Statements);
end if;
F := Next_Node (F);
end loop;
end if;
Profile := New_List (ADN.K_Parameter_Profile);
-- Append the 'Status' variable to the call profile
N := Make_Defining_Identifier (PN (P_Status));
ADU.Append_Node_To_List (N, Profile);
-- For each call sequence, we add the subprogram that
-- handles it.
Call_Seq := First_Node (Calls (S));
while Present (Call_Seq) loop
N := Make_Attribute_Designator
(Make_Defining_Identifier
(Map_Ada_Call_Seq_Subprogram_Name (S, Call_Seq)),
A_Access);
ADU.Append_Node_To_List (N, Profile);
Call_Seq := Next_Node (Call_Seq);
end loop;
-- Call the implementation subprogram
-- Add the proper `with' clause
N := Make_Designator (Unit_Name (Get_Source_Name (S)));
Add_With_Package (N);
N := Make_Designator
(Local_Name (Get_Source_Name (S)),
Unit_Name (Get_Source_Name (S)));
N := Make_Subprogram_Call (ADN.Defining_Identifier (N), Profile);
ADU.Append_Node_To_List (N, Statements);
-- Update the OUT parameters from the corresponding
-- record fields.
if not AAU.Is_Empty (Features (S)) then
F := First_Node (Features (S));
while Present (F) loop
if Kind (F) = K_Parameter_Instance and then Is_Out (F) then
N := Make_Assignment_Statement
(Make_Designator
(To_Ada_Name (Display_Name (Identifier (F)))),
Make_Designator
(To_Ada_Name (Display_Name (Identifier (F))),
PN (P_Status)));
ADU.Append_Node_To_List (N, Statements);
end if;
F := Next_Node (F);
end loop;
end if;
return Make_Subprogram_Implementation
(Spec, Declarations, Statements);
when Subprogram_Lustre =>
-- In PolyORB-HI-Ada, a Lustre subprogram is mapped onto an Ada
-- subprogram that raises an exception to warn the user.
N := Make_Exception_Declaration
(Make_Defining_Identifier
(EN (E_NYI)));
ADU.Append_Node_To_List (N, Declarations);
N := Make_Raise_Statement (Make_Defining_Identifier (EN (E_NYI)));
ADU.Append_Node_To_List (N, Statements);
return Make_Subprogram_Implementation
(Spec, Declarations, Statements);
when others =>
Display_Located_Error
(Loc (S),
"This kind of subprogram is not supported: "
& Get_Subprogram_Kind (S)'Img,
Fatal => True);
return No_Node;
end case;
end Map_Ada_Subprogram_Body;
--------------------------------------
-- Map_Ada_Call_Seq_Subprogram_Spec --
--------------------------------------
function Map_Ada_Call_Seq_Subprogram_Spec
(Spg : Node_Id;
Seq : Node_Id)
return Node_Id
is
Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
N : Node_Id;
begin
N := Make_Parameter_Specification
(Make_Defining_Identifier (PN (P_Status)),
Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (Spg)),
Mode_Inout);
ADU.Append_Node_To_List (N, Profile);
N := Make_Subprogram_Specification
(Make_Defining_Identifier
(Map_Ada_Call_Seq_Subprogram_Name
(Spg, Seq)),
Profile);
return N;
end Map_Ada_Call_Seq_Subprogram_Spec;
--------------------------------------
-- Map_Ada_Call_Seq_Subprogram_Body --
--------------------------------------
function Map_Ada_Call_Seq_Subprogram_Body
(Spg : Node_Id;
Seq : Node_Id)
return Node_Id
is
Spec : constant Node_Id := Map_Ada_Call_Seq_Subprogram_Spec
(Spg, Seq);
Declarations : constant List_Id := New_List (ADN.K_Declaration_List);
Statements : constant List_Id := New_List (ADN.K_Statement_List);
begin
Handle_Call_Sequence
(Spg,
Make_Defining_Identifier (PN (P_Status)),
Seq,
Declarations,
Statements);
return Make_Subprogram_Implementation (Spec, Declarations, Statements);
end Map_Ada_Call_Seq_Subprogram_Body;
------------------------------------
-- Map_Ada_Subprogram_Status_Name --
------------------------------------
function Map_Ada_Subprogram_Status_Name (S : Node_Id) return Name_Id is
begin
pragma Assert (Is_Subprogram (S) or else
Kind (S) = K_Call_Instance);
Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (S))));
Add_Str_To_Name_Buffer ("_Status");
return Name_Find;
end Map_Ada_Subprogram_Status_Name;
--------------------------------------
-- Map_Ada_Call_Seq_Subprogram_Name --
--------------------------------------
function Map_Ada_Call_Seq_Subprogram_Name
(Spg : Node_Id;
Seq : Node_Id)
return Name_Id
is
Spg_Name : Name_Id;
Seg_Name : Name_Id;
begin
pragma Assert
(Is_Subprogram (Spg) and then Kind (Seq) = K_Call_Sequence_Instance);
Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Spg)));
Seg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Seq)));
Get_Name_String (Spg_Name);
Add_Char_To_Name_Buffer ('_');
Get_Name_String_And_Append (Seg_Name);
return Name_Find;
end Map_Ada_Call_Seq_Subprogram_Name;
----------------------------------
-- Map_Ada_Call_Seq_Access_Name --
----------------------------------
function Map_Ada_Call_Seq_Access_Name (S : Node_Id) return Name_Id
is
Spg_Name : Name_Id;
begin
pragma Assert (Is_Subprogram (S));
Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (S)));
Get_Name_String (Spg_Name);
Add_Str_To_Name_Buffer ("_Sequence_Access");
return Name_Find;
end Map_Ada_Call_Seq_Access_Name;
-----------------------------
-- Map_Ada_Call_Seq_Access --
-----------------------------
function Map_Ada_Call_Seq_Access (S : Node_Id) return Node_Id is
Profile : constant List_Id := New_List (ADN.K_Parameter_Profile);
N : Node_Id;
begin
N := Make_Parameter_Specification
(Make_Defining_Identifier (PN (P_Status)),
Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (S)),
Mode_Inout);
ADU.Append_Node_To_List (N, Profile);
N := Make_Subprogram_Specification (No_Node, Profile);
N := Make_Full_Type_Declaration
(Make_Defining_Identifier (Map_Ada_Call_Seq_Access_Name (S)),
Make_Access_Type_Definition (N));
return N;
end Map_Ada_Call_Seq_Access;
-------------------------------
-- Map_Ada_Subprogram_Status --
-------------------------------
function Map_Ada_Subprogram_Status (S : Node_Id) return Node_Id is
Fields : constant List_Id := New_List (ADN.K_Component_List);
F : Node_Id;
N : Node_Id;
begin
pragma Assert (Is_Subprogram (S));
if not AAU.Is_Empty (Features (S)) then
F := First_Node (Features (S));
while Present (F) loop
N := Make_Component_Declaration
(Map_Ada_Defining_Identifier (F),
Map_Ada_Data_Type_Designator (Corresponding_Instance (F)));
ADU.Append_Node_To_List (N, Fields);
F := Next_Node (F);
end loop;
else
Display_Located_Error
(Loc (S),
"This hybrid subprogram has no parameters",
Fatal => True);
end if;
N := Make_Full_Type_Declaration
(Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (S)),
Make_Record_Definition (Fields));
return N;
end Map_Ada_Subprogram_Status;
--------------------------
-- Handle_Call_Sequence --
--------------------------
procedure Handle_Call_Sequence
(Caller : Node_Id;
Caller_State : Node_Id;
Call_Seq : Node_Id;
Declarations : List_Id;
Statements : List_Id)
is
Spg_Call : Node_Id;
Spg : Node_Id;
Destination_F : Node_Id;
Source_F : Node_Id;
Source_Parent : Node_Id;
Call_Profile : List_Id;
Param_Value : Node_Id;
Owner_Object : Node_Id;
N : Node_Id;
M : Node_Id;
F : Node_Id;
Parent : Node_Id;
Hybrid : constant Boolean := Is_Subprogram (Caller) and then
Get_Subprogram_Kind (Caller) = Subprogram_Hybrid_Ada_95;
begin
-- The lists have to be created
if Declarations = No_List or else Statements = No_List then
raise Program_Error with "Lists have to be created before any call "
& "to Handle_Call_Sequence";
end if;
-- The call sequence must contain at least one call to a
-- subprogram.
if AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then
Display_Located_Error
(Loc (Call_Seq),
"Empty call sequence",
Fatal => False,
Warning => True);
return;
end if;
Spg_Call := First_Node (Subprogram_Calls (Call_Seq));
while Present (Spg_Call) loop
Spg := Corresponding_Instance (Spg_Call);
Call_Profile := New_List (ADN.K_List_Id);
if not AAU.Is_Empty (Features (Spg)) then
F := First_Node (Features (Spg));
while Present (F) loop
if Kind (F) = K_Parameter_Instance
and then Is_Out (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AAU.Length (Destinations (F)) = 0 then
Display_Located_Error
(Loc (F),
"This OUT parameter is not connected to"
& " any destination",
Fatal => True);
elsif AAU.Length (Destinations (F)) > 1 then
Display_Located_Error
(Loc (F),
"This OUT parameter has too many destinations",
Fatal => True);
end if;
-- At this point, we have a subprogram call
-- parameter that has exactly one destination.
Destination_F := Item (First_Node (Destinations (F)));
-- For each OUT parameter, we declare a local
-- variable if the OUT parameter is connected to
-- another subprogram call or if the caller is a
-- thread. Otherwise, we use the corresponding
-- caller subprogram parameter.
-- The parameter association value takes 4 possible
-- values (see the (1), (2), (3) and (4) comments
-- below.
if Is_Thread (Caller) then
-- Here we declare a variable based on the
-- thread feature name.
N := Make_Object_Declaration
(Defining_Identifier => Map_Ada_Defining_Identifier
(Destination_F, "V"),
Object_Definition => Map_Ada_Data_Type_Designator
(Corresponding_Instance (Destination_F)));
ADU.Append_Node_To_List (N, Declarations);
-- (1) If we declared a local variable, we use it
-- as parameter value.
Param_Value := Map_Ada_Defining_Identifier
(Destination_F, "V");
elsif Parent_Component (Destination_F) /= Caller then
-- Here, we map the variable name from the
-- subprogram *call* name and the feature
-- name. This avoids name clashing when a
-- subprogram calls twice the same subprogram.
N := Make_Object_Declaration
(Defining_Identifier => Make_Defining_Identifier
(Map_Ada_Full_Parameter_Name
(Spg_Call, F)),
Object_Definition => Map_Ada_Data_Type_Designator
(Corresponding_Instance (F)));
ADU.Append_Node_To_List (N, Declarations);
-- (2) If we declared a local variable, we use it
-- as parameter value.
Param_Value := Make_Designator
(Map_Ada_Full_Parameter_Name
(Spg_Call, F));
elsif Hybrid then
-- (3) If the calleD parameter is connected to
-- the calleR parameter and then the calleR
-- IS hybrid, then we use the 'Status'
-- record field corresponding to the calleR
-- parameter.
Param_Value := Make_Designator
(To_Ada_Name (Display_Name (Identifier (F))),
PN (P_Status));
else
-- (4) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- is NOT hybrid, then we use simply the
-- corresponding parameter of the calleR.
Param_Value := Map_Ada_Defining_Identifier
(Destination_F);
end if;
-- For each OUT parameter we build a parameter
-- association of the actual profile of the
-- implementation subprogram call =>
-- .
N := Make_Parameter_Association
(Selector_Name => Map_Ada_Defining_Identifier (F),
Actual_Parameter => Param_Value);
ADU.Append_Node_To_List (N, Call_Profile);
elsif Kind (F) = K_Parameter_Instance
and then Is_In (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AAU.Length (Sources (F)) = 0 then
Display_Located_Error
(Loc (F),
"This IN parameter is not connected to"
& " any source"
& Image (Loc (Caller)),
Fatal => True);
elsif AAU.Length (Sources (F)) > 1 then
Display_Located_Error
(Loc (F),
"This IN parameter has too many sources",
Fatal => True);
end if;
-- Here we have an IN parameter with exactly one
-- source.
Source_F := Item (First_Node (Sources (F)));
-- Get the source feature parent
Source_Parent := Parent_Component (Source_F);
-- The parameter value of the built parameter
-- association can take 4 different values (see
-- comments (1), (2), (3) and (4) below).
if Is_Thread (Source_Parent) then
-- (1) If the Parent of 'Source_F' is a thread,
-- then we use the local variable corresponding
-- to the IN port.
Param_Value := Map_Ada_Defining_Identifier
(Source_F, "V");
elsif Source_Parent /= Caller then
-- (2) If the the source call is different from
-- the englobing subprogram, we use the
-- formerly declared variable.
Param_Value := Make_Designator
(Map_Ada_Full_Parameter_Name
(Parent_Subcomponent (Source_Parent), Source_F));
elsif Hybrid then
-- (3) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- IS hybrid, the we use the 'Status' record
-- field corresponding to the calleR
-- parameter.
Param_Value := Make_Selected_Component
(Make_Defining_Identifier (PN (P_Status)),
Map_Ada_Defining_Identifier (Source_F));
else
-- (4) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- is NOT hybrid, then we use simply the
-- corresponding parameter of the calleR.
Param_Value := Map_Ada_Defining_Identifier (Source_F);
end if;
-- For each IN parameter we build a parameter
-- association association of the actual profile of
-- the implementaion subprogram call =>
-- .
N := Make_Parameter_Association
(Selector_Name => Map_Ada_Defining_Identifier (F),
Actual_Parameter => Param_Value);
ADU.Append_Node_To_List (N, Call_Profile);
end if;
F := Next_Node (F);
end loop;
end if;
if not AAU.Is_Empty (Path (Spg_Call)) then
-- FIXME: Feature subprograms that have OUT ports are not
-- supported yet.
if Has_Out_Ports (Spg) then
Display_Located_Error
(Loc (Spg),
"Feature subprograms that have OUT ports are not"
& " supported yet",
Fatal => True);
end if;
-- If this is a feature subprogram call, generate a call
-- to the corresponding method.
N := Message_Comment ("Invoking method");
ADU.Append_Node_To_List (N, Statements);
N := Map_Ada_Defining_Identifier
(Item (Last_Node (Path (Spg_Call))));
-- Get the actual owner object
-- FIXME: THIS WORKS ONLY FOR A LOCAL OBJECT
Owner_Object := Get_Actual_Owner (Spg_Call);
Set_Homogeneous_Parent_Unit_Name
(N,
Extract_Designator
(ADN.Object_Node
(Backend_Node
(Identifier
(Owner_Object)))));
N := Make_Subprogram_Call (N, Call_Profile);
ADU.Append_Node_To_List (N, Statements);
else
-- If this is a classic subprogram, and if it has OUT
-- ports, we declare an additional status variable and
-- pass it to the implementation as the last INOUT
-- parameter.
if Has_Out_Ports (Spg) then
N := Make_Object_Declaration
(Defining_Identifier => Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (Spg_Call)),
Object_Definition => Extract_Designator
(ADN.Type_Definition_Node
(Backend_Node (Identifier (Spg)))));
ADU.Append_Node_To_List (N, Declarations);
N := Make_Parameter_Association
(Make_Defining_Identifier (PN (P_Status)),
Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (Spg_Call)));
ADU.Append_Node_To_List (N, Call_Profile);
end if;
-- Call the implementation.
N := Message_Comment ("Call implementation");
ADU.Append_Node_To_List (N, Statements);
N := Make_Subprogram_Call
(Extract_Designator
(ADN.Subprogram_Node
(Backend_Node
(Identifier
(Spg)))),
Call_Profile);
ADU.Append_Node_To_List (N, Statements);
-- After the implementation is called and if the called
-- subprogram has OUT port, we trigger the destination of
-- these ports, which are out ports of the containing
-- thread or subprogram.
if Has_Out_Ports (Spg) then
F := First_Node (Features (Spg));
while Present (F) loop
if Kind (F) = K_Port_Spec_Instance then
-- Verify whether the port has been triggered
-- then send the value to all its destinations.
declare
D : Node_Id;
Profile : List_Id;
Aggr : List_Id;
St : constant List_Id := ADU.New_List
(ADN.K_Statement_List);
begin
D := First_Node (Destinations (F));
while Present (D) loop
-- D is necessarily a feature of Caller,
-- otherwise we have a serious problem.
pragma Assert
(Parent_Component (Item (D)) = Caller);
Profile := ADU.New_List (ADN.K_List_Id);
ADU.Append_Node_To_List
(ADU.Copy_Node (Caller_State), Profile);
Aggr := ADU.New_List (ADN.K_List_Id);
N := Make_Component_Association
(Make_Defining_Identifier (CN (C_Port)),
Map_Ada_Defining_Identifier (Item (D)));
ADU.Append_Node_To_List (N, Aggr);
if Ocarina.ME_AADL.AADL_Instances.Nodes.Is_Data
(Item (D)) then
N := Map_Ada_Defining_Identifier (F);
-- We do not put use clause to avoid
-- name clashing, so enumerators have
-- to be qualified.
M := Extract_Designator
(ADN.Port_Enumeration_Node
(Backend_Node (Identifier (Spg))));
Parent := ADN.Parent_Unit_Name (M);
N := Make_Selected_Component (Parent, N);
N := Make_Qualified_Expression
(M, Make_Record_Aggregate (Make_List_Id (N)));
N := Make_Subprogram_Call
(Extract_Designator
(ADN.Get_Value_Node
(Backend_Node
(Identifier
(Spg)))),
Make_List_Id
(Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (Spg_Call)),
N));
N := Make_Component_Association
(Make_Defining_Identifier
(Map_Ada_Component_Name (Item (D))),
Make_Selected_Component
(N,
Make_Defining_Identifier
(Map_Ada_Component_Name (F))));
ADU.Append_Node_To_List (N, Aggr);
end if;
N := Make_Qualified_Expression
(Extract_Designator
(ADN.Port_Interface_Node
(Backend_Node
(Identifier
(Caller)))),
Make_Record_Aggregate (Aggr));
ADU.Append_Node_To_List (N, Profile);
-- Call, the Put_Value routine
-- corresponding to the destination.
N := Make_Subprogram_Call
(Extract_Designator
(ADN.Put_Value_Node
(Backend_Node
(Identifier
(Caller)))),
Profile);
ADU.Append_Node_To_List (N, St);
D := Next_Node (D);
end loop;
-- Make the if statement
Profile := ADU.New_List (ADN.K_List_Id);
N := Make_Defining_Identifier
(Map_Ada_Subprogram_Status_Name (Spg_Call));
ADU.Append_Node_To_List (N, Profile);
N := Map_Ada_Defining_Identifier (F);
-- We do not put use clause to avoid name
-- clashing, so enumerators have to be fully
-- qualified.
M := Extract_Designator
(ADN.Port_Enumeration_Node
(Backend_Node (Identifier (Spg))));
Parent := ADN.Parent_Unit_Name (M);
N := Make_Selected_Component (Parent, N);
N := Make_Qualified_Expression
(M, Make_Record_Aggregate (Make_List_Id (N)));
ADU.Append_Node_To_List (N, Profile);
N := Make_Subprogram_Call
(Extract_Designator
(ADN.Get_Count_Node
(Backend_Node
(Identifier (Spg)))),
Profile);
N := Make_Expression
(N,
Op_Greater_Equal,
Make_Literal (ADV.New_Integer_Value (1, 1, 10)));
N := Make_If_Statement
(Condition => N,
Then_Statements => St);
ADU.Append_Node_To_List (N, Statements);
end;
end if;
F := Next_Node (F);
end loop;
end if;
end if;
Spg_Call := Next_Node (Spg_Call);
end loop;
end Handle_Call_Sequence;
---------------------------
-- Get_Ada_Default_Value --
---------------------------
function Get_Ada_Default_Value (D : Node_Id) return Node_Id is
Data_Representation : Supported_Data_Representation;
Result : Node_Id;
begin
pragma Assert (AAU.Is_Data (D));
Data_Representation := Get_Data_Representation (D);
case Data_Representation is
when Data_Integer =>
-- For integers, default value is 0
Result := ADU.Make_Literal
(ADV.New_Integer_Value (0, 1, 10));
when Data_Float | Data_Fixed =>
-- For reals, the default value is 0.0
Result := ADU.Make_Literal
(ADV.New_Floating_Point_Value (0.0));
when Data_Boolean =>
-- For booleans, the default value is FALSE
Result := ADU.Make_Literal
(ADV.New_Boolean_Value (False));
when Data_Character =>
-- For characters, the default value is the space ' '
Result := ADU.Make_Literal
(ADV.New_Character_Value (Character'Pos (' ')));
when Data_Wide_Character =>
-- For wide characters, the default value is the wide
-- space ' '.
Result := ADU.Make_Literal
(ADV.New_Character_Value (Wide_Character'Pos (' '), True));
when Data_String =>
-- For strings, the default value is the null bounded string
Result := Make_Selected_Component
(Map_Ada_Package_Identifier (D),
Make_Defining_Identifier (PN (P_Null_Bounded_String)));
when Data_Wide_String =>
-- For wide strings, the default value is the null
-- bounded wide string.
Result := Make_Selected_Component
(Map_Ada_Package_Identifier (D),
Make_Defining_Identifier (PN (P_Null_Bounded_Wide_String)));
when Data_Array =>
-- The default value for an array type is an array
-- aggregate of the default value of the array element
-- type.
-- We use "'Range =>" instead of using "others =>" to
-- avoid implicit loops.
Result := Make_Record_Aggregate
(Make_List_Id
(Make_Element_Association
(Make_Attribute_Designator
(Map_Ada_Defining_Identifier (D), A_Range),
Get_Ada_Default_Value
(ATN.Entity
(ATN.First_Node
(Get_Base_Type (D)))))));
when Data_Struct =>
-- For data record, the default value is an aggregate
-- list of default values of all the record aggregates.
declare
Aggregates : constant List_Id
:= ADU.New_List (ADN.K_Component_List);
S : Node_Id;
C : Node_Id;
begin
if not AAU.Is_Empty (Subcomponents (D)) then
S := First_Node (Subcomponents (D));
while Present (S) loop
C := ADU.Make_Component_Association
(Map_Ada_Defining_Identifier (S),
Get_Ada_Default_Value (Corresponding_Instance (S)));
ADU.Append_Node_To_List (C, Aggregates);
S := Next_Node (S);
end loop;
Result := ADU.Make_Record_Aggregate (Aggregates);
else
Display_Located_Error
(Loc (D),
"Record types must not be empty!",
Fatal => True);
end if;
end;
when Data_With_Accessors =>
-- This is definitely a code generation error
raise Program_Error with "Data types with accessors should"
& " not have default values";
when others =>
Display_Located_Error
(Loc (D), "Cannot generate default value for type",
Fatal => False, Warning => True);
Result := No_Node;
end case;
return Result;
end Get_Ada_Default_Value;
-------------------------------------------
-- Map_Ada_Namespace_Defining_Identifier --
-------------------------------------------
function Map_Ada_Namespace_Defining_Identifier
(N : Node_Id;
Prefix : String := "")
return Node_Id
is
Name_List : List_Id;
I : Node_Id;
Id : Node_Id;
Parent_Id : Node_Id := No_Node;
begin
if Name (Identifier (N)) = No_Name then
-- This is the unnamed namespace
if Prefix = "" then
-- Display an error if the user did not give a prefix
raise Program_Error with "You must provide a prefix to map the"
& " unnamed namespace";
end if;
return ADU.Make_Defining_Identifier (Get_String_Name (Prefix));
else
-- This is a "classical" namespace obtained from the
-- instanciation of an AADL package.
Name_List := Split_Name (N);
if Prefix /= "" then
Parent_Id := ADU.Make_Defining_Identifier
(Get_String_Name (Prefix));
end if;
I := First_Node (Name_List);
while Present (I) loop
Id := ADU.Make_Defining_Identifier (Display_Name (I));
ADN.Set_Parent_Unit_Name (Id, Parent_Id);
Parent_Id := Id;
I := Next_Node (I);
end loop;
return Id;
end if;
end Map_Ada_Namespace_Defining_Identifier;
-------------
-- To_Bits --
-------------
How_Many_Bits : constant array (Size_Units) of Unsigned_Long_Long
:= (Bit => 1,
Properties.Byte => 8,
Kilo_Byte => 8 * 1_000,
Mega_Byte => 8 * 1_000_000,
Giga_Byte => 8 * 1_000_000_000,
Tera_Byte => 8 * 1_000_000_000_000);
-- To easily convert sizes into bits
function To_Bits (S : Size_Type) return Unsigned_Long_Long is
begin
return S.S * How_Many_Bits (S.U);
end To_Bits;
----------------
-- To_Seconds --
----------------
function To_Seconds (S : Time_Type) return Long_Double is
Value : constant Long_Double := Long_Double (S.T);
begin
case S.U is
when Picosecond =>
return Value / 1_000_000_000_000.0;
when Nanosecond =>
return Value / 1_000_000_000.0;
when Microsecond =>
return Value / 1_000_000.0;
when Millisecond =>
return Value / 1_000.0;
when Second =>
return Value;
when Minute =>
return Value * 60.0;
when Hour =>
return Value * 3600.0;
end case;
end To_Seconds;
---------------------
-- To_Milliseconds --
---------------------
function To_Milliseconds (S : Time_Type) return Unsigned_Long_Long is
begin
return Unsigned_Long_Long (To_Seconds (S) * 1_000.0);
end To_Milliseconds;
--------------
-- To_Bytes --
--------------
How_Many_Bytes : constant array (Size_Units) of Unsigned_Long_Long
:= (Bit => 0,
Properties.Byte => 1,
Kilo_Byte => 1_000,
Mega_Byte => 1_000_000,
Giga_Byte => 1_000_000_000,
Tera_Byte => 1_000_000_000_000);
-- To easily convert sizes into bytes
function To_Bytes (S : Size_Type) return Unsigned_Long_Long is
begin
case S.U is
when Bit =>
-- If the size can be converted into byte, we are OK,
-- else, this is an error.
if S.S mod 8 = 0 then
return S.S / 8;
else
return 0;
end if;
when others =>
return S.S * How_Many_Bytes (S.U);
end case;
end To_Bytes;
----------------------------------
-- Check_Connection_Consistency --
----------------------------------
procedure Check_Connection_Consistency (C : Node_Id) is
B : Node_Id;
C_Src : Node_Id;
C_Dst : Node_Id;
P_Src : Node_Id;
P_Dst : Node_Id;
procedure Check_Port_Consistency (P : Node_Id);
-- Check that a port belongs to a process and complains with an
-- error otherwise.
procedure Check_Processes_Bus_Access (P : Node_Id; Bus : Node_Id);
-- Check that the process P have access to the bus 'Bus'
-- through its bound processor.
----------------------------
-- Check_Port_Consistency --
----------------------------
procedure Check_Port_Consistency (P : Node_Id) is
begin
if not Is_Process (Parent_Component (P)) then
Display_Located_Error
(Loc (P),
"The parent of this port is not a process and it"
& " is involved in a system-level connection in "
& Image (Loc (C)),
Fatal => True);
end if;
end Check_Port_Consistency;
--------------------------------
-- Check_Processes_Bus_Access --
--------------------------------
procedure Check_Processes_Bus_Access (P : Node_Id; Bus : Node_Id) is
CPU : Node_Id;
F : Node_Id := No_Node;
S : Node_Id;
begin
-- Get the processor to which P is bound
CPU := Get_Bound_Processor (P);
-- Loop on the features of CPU to find the required access
-- to the Bus.
if not AAU.Is_Empty (Features (CPU)) then
F := First_Node (Features (CPU));
Outer_Loop :
while Present (F) loop
if Kind (F) = K_Subcomponent_Access_Instance then
-- Verify that the required access is indeed connected to
-- the bus subcomponent correspondiong to Bus.
if not AAU.Is_Empty (Sources (F)) then
S := First_Node (Sources (F));
while Present (S) loop
exit Outer_Loop when
Item (S) = Parent_Subcomponent (B);
S := Next_Node (S);
end loop;
end if;
end if;
F := Next_Node (F);
end loop Outer_Loop;
end if;
if No (F) then
-- This means we went through all the previous loop
-- without finding any matching bus access or that we did
-- never enter the loop.
Display_Located_Error
(Loc (Parent_Subcomponent (CPU)),
"This process has no access to the bus declared at "
& Image (Loc (Parent_Subcomponent (Bus))),
Fatal => True);
end if;
end Check_Processes_Bus_Access;
begin
pragma Assert (Kind (C) = K_Connection_Instance);
-- We only check connection at system level
if not Is_System (Parent_Component (C)) then
return;
end if;
-- We only check port connections
if not
(Get_Category_Of_Connection (C) in Port_Connection_Type'Range)
then
return;
end if;
-- Get the connecion bus
B := Get_Bound_Bus (C);
-- Get the connection extremities
C_Src := Get_Referenced_Entity (Source (C));
C_Dst := Get_Referenced_Entity (Destination (C));
-- Check that the connection connects two ports
if Kind (C_Src) /= K_Port_Spec_Instance or else
Kind (C_Src) /= K_Port_Spec_Instance
then
-- FIXME: May be refined in the future when distributed
-- shared variable will be supported.
Display_Located_Error
(Loc (C),
"One of the extremities of this connection is not a port",
Fatal => True);
end if;
-- Check that the connected ports belongs to processes
Check_Port_Consistency (C_Src);
Check_Port_Consistency (C_Dst);
-- Get the processes
P_Src := Parent_Component (C_Src);
P_Dst := Parent_Component (C_Dst);
-- Check that the two processes have an access to the Bus to
-- which the connection is bound through their respective bound
-- processors.
Check_Processes_Bus_Access (P_Src, B);
Check_Processes_Bus_Access (P_Dst, B);
-- Everything is OK
end Check_Connection_Consistency;
------------------------------
-- Check_Thread_Consistency --
------------------------------
procedure Check_Thread_Consistency (T : Node_Id) is
begin
pragma Assert (Is_Thread (T));
-- Check implementation kind
if Get_Thread_Implementation_Kind (T) = Thread_Unknown then
Display_Located_Error
(Loc (T),
"Unknown thread implementation kind",
Fatal => True);
end if;
end Check_Thread_Consistency;
------------------------------------
-- Get_Subcomponent_Access_Source --
------------------------------------
function Get_Subcomponent_Access_Source (S : Node_Id) return Node_Id is
Src : Node_Id;
begin
pragma Assert (Kind (S) = K_Subcomponent_Access_Instance);
-- Raise an error if the provided access is not connected
if AAU.Is_Empty (Sources (S)) then
Display_Located_Error
(Loc (S),
"Required access not connected to anything",
Fatal => True);
end if;
-- Loop on the sources of the access until finding a
-- subcomponent.
Src := First_Node (Sources (S));
while Present (Src) loop
exit when Kind (Item (Src)) = K_Subcomponent_Instance;
-- Raise an error if the provided access is not connected
if AAU.Is_Empty (Sources (Item (Src))) then
Display_Located_Error
(Loc (Item (Src)),
"Required access not connected to anything",
Fatal => True);
end if;
Src := First_Node (Sources (Item (Src)));
end loop;
-- If Src is No_Node, this means that the required access chain
-- does not end with a subcomponent as stated by the AADL
-- standard.
if No (Src) then
Display_Located_Error
(Loc (S),
"Required access chain does not end with a subcomponent",
Fatal => True);
end if;
return Item (Src);
end Get_Subcomponent_Access_Source;
-------------------------
-- Get_First_Processor --
-------------------------
function Get_First_Processor (P : Node_Id) return Node_Id is
C : Node_Id;
begin
pragma Assert (Is_System (P));
C := First_Node (Subcomponents (P));
while Present (C) loop
if Is_Processor (Corresponding_Instance (C)) then
return C;
end if;
C := Next_Node (C);
end loop;
return No_Node;
end Get_First_Processor;
----------------------------
-- Get_Connection_Pattern --
----------------------------
function Get_Connection_Pattern (E : Node_Id)
return Connection_Pattern_Kind
is
L : List_Id;
N : Node_Id;
Current_Process : Node_Id;
Remote_Process : Node_Id;
Return_Value : Connection_Pattern_Kind;
begin
if Is_Process (Parent_Component (E)) then
Current_Process := Parent_Component (E);
elsif Is_Device (Parent_Component (E)) then
Current_Process := Parent_Component (E);
elsif Is_Thread (Parent_Component (E)) then
Current_Process := Get_Container_Process
(Parent_Subcomponent (Parent_Component (E)));
end if;
Return_Value := Intra_Process;
if Is_In (E) then
L := Get_Source_Ports (E);
else
L := Get_Destination_Ports (E);
end if;
if L = No_List or else AAU.Is_Empty (L) then
return Inter_Process;
end if;
N := First_Node (L);
while Present (N) loop
Remote_Process := Get_Container_Process
(Parent_Component (Item (N)));
if Remote_Process /= Current_Process then
Return_Value := Inter_Process;
end if;
N := Next_Node (N);
end loop;
return Return_Value;
end Get_Connection_Pattern;
------------------
-- Compare_Time --
------------------
function "<=" (T1 : Time_Type; T2 : Time_Type)
return Boolean
is
T1_Value : Unsigned_Long_Long;
T2_Value : Unsigned_Long_Long;
begin
case T1.U is
when Picosecond | Nanosecond | Microsecond =>
return True;
-- At this time, we assume than our runtimes
-- cannot handle a granularity less than the
-- millisecond. So, we consider nanosecond,
-- picosecond and microsecond equals.
-- FIXME: Must be fixed later
when Millisecond =>
T1_Value := T1.T;
when Second =>
T1_Value := T1.T * 1000;
when Minute =>
T1_Value := T1.T * 60 * 1000;
when Hour =>
T1_Value := T1.T * 3600 * 1000;
end case;
case T2.U is
when Picosecond | Nanosecond | Microsecond =>
return True;
-- At this time, we assume than our runtimes
-- cannot handle a granularity less than the
-- millisecond. So, we consider nanosecond,
-- picosecond and microsecond equals.
-- FIXME: Must be fixed later
when Millisecond =>
T2_Value := T2.T;
when Second =>
T2_Value := T2.T * 1000;
when Minute =>
T2_Value := T2.T * 60 * 1000;
when Hour =>
T2_Value := T2.T * 3600 * 1000;
end case;
return (T1_Value <= T2_Value);
end "<=";
-----------------------
-- Get_Accessed_Data --
-----------------------
function Get_Accessed_Data (Data_Access : Node_Id) return Node_Id is
Accessed_Component : Node_Id;
begin
if not AAU.Is_Empty (Sources (Data_Access)) then
Accessed_Component := Item
(First_Node (Sources (Data_Access)));
if Kind (Accessed_Component)
= K_Subcomponent_Access_Instance then
return Get_Accessed_Data (Accessed_Component);
else
return Accessed_Component;
end if;
else
return No_Node;
end if;
end Get_Accessed_Data;
---------------------------
-- Get_Device_of_Process --
---------------------------
function Get_Device_Of_Process
(Bus : Node_Id; Process : Node_Id)
return Node_Id
is
The_Process : Node_Id := Process;
The_System : Node_Id;
S : Node_Id;
Device : Node_Id;
begin
if not Is_Process (The_Process) then
The_Process := Corresponding_Instance
(Get_Container_Process (Parent_Subcomponent (Process)));
end if;
The_System := Parent_Component
(Parent_Subcomponent
(Corresponding_Instance
(Parent_Subcomponent (The_Process))));
if Present (Bus)
and then not AAU.Is_Empty (Connections (The_System))
then
S := First_Node (Connections (The_System));
-- Check whether a device is attached to this bus
while Present (S) loop
if Kind (S) = K_Connection_Instance
and then Get_Category_Of_Connection (S) = CT_Access_Bus
then
Device := Item (First_Node (Path (Destination (S))));
if True
-- We actually found a device
and then Present (Device)
and then AAU.Is_Device (Corresponding_Instance (Device))
-- Process and device are on the same processor
and then Get_Bound_Processor
(Corresponding_Instance (Device))
= Get_Bound_Processor (The_Process)
-- This device is connected to the bus
and then Parent_Subcomponent (Bus)
= Item (First_Node (Path (Source (S))))
then
-- Note, for now, we assume there is only one
-- device at each end of the bus.
return Device;
end if;
end if;
S := Next_Node (S);
end loop;
end if;
return No_Node;
end Get_Device_Of_Process;
------------------
-- Is_Connected --
------------------
function Is_Connected
(Bus : Node_Id; Device : Node_Id)
return Boolean
is
The_System : Node_Id;
S : Node_Id;
begin
The_System := Parent_Component
(Parent_Subcomponent
(Corresponding_Instance
(Parent_Subcomponent (Bus))));
pragma Assert (Is_System (The_System));
if Present (Bus)
and then not AAU.Is_Empty (Connections (The_System))
then
S := First_Node (Connections (The_System));
-- Check whether Device is attached to this bus
while Present (S) loop
if Kind (S) = K_Connection_Instance
and then Get_Category_Of_Connection (S) = CT_Access_Bus
then
if True
-- This device is connected to the bus
and then Parent_Subcomponent (Bus)
= Item (First_Node (Path (Source (S))))
and then Device = Item (First_Node (Path (Destination (S))))
then
-- Note, for now, we assume there is only one
-- device at each end of the bus.
return True;
end if;
end if;
S := Next_Node (S);
end loop;
end if;
return False;
end Is_Connected;
-----------------------
-- Is_Protected_Data --
-----------------------
function Is_Protected_Data (Data_Component : Node_Id) return Boolean is
Concurrency_Protocol : Supported_Concurrency_Control_Protocol;
begin
Concurrency_Protocol := Get_Concurrency_Protocol (Data_Component);
return Concurrency_Protocol = Concurrency_Protected_Access
or else Concurrency_Protocol = Concurrency_Priority_Ceiling;
end Is_Protected_Data;
----------------------
-- Get_Port_By_Name --
----------------------
function Get_Port_By_Name (Port : Node_Id; Component : Node_Id)
return Node_Id is
F : Node_Id;
begin
if Component = No_Node then
return No_Node;
end if;
F := First_Node (Features (Component));
while Present (F) loop
if Name (Identifier (F)) =
Name (Identifier (Port)) then
return F;
end if;
F := Next_Node (F);
end loop;
return No_Node;
end Get_Port_By_Name;
----------------
-- Is_Virtual --
----------------
function Is_Virtual (Port : Node_Id) return Boolean is
Remote_Port : Node_Id;
Remote_Processor : Node_Id;
Local_Processor : Node_Id;
begin
if Port = No_Node then
return False;
end if;
if Is_In (Port) and then not Is_Out (Port) then
if AAU.Is_Empty (Sources (Port)) then
Display_Error
("IN ports must be connected !",
Fatal => True);
end if;
Remote_Port := Item (First_Node (Sources (Port)));
elsif Is_Out (Port) and then not Is_In (Port) then
if AAU.Is_Empty (Destinations (Port)) then
Display_Error
("IN ports must be connected !",
Fatal => True);
end if;
Remote_Port := Item (First_Node (Destinations (Port)));
else
Display_Error
("Virtual port cannot be IN and OUT at the same time",
Fatal => True);
end if;
Local_Processor := Parent_Component
(Parent_Subcomponent
(Get_Bound_Processor (Parent_Component (Port))));
Remote_Processor := Parent_Component
(Parent_Subcomponent
(Get_Bound_Processor (Parent_Component (Remote_Port))));
return Is_Device (Parent_Component (Port)) and then
(Local_Processor /= Remote_Processor);
end Is_Virtual;
-----------------------------------------------------
-- Get_Instance_Type_Associated_With_Virtual_Bus --
-----------------------------------------------------
function Get_Instance_Type_Associated_With_Virtual_Bus
(Port : Node_Id) return Node_Id
is
Virtual_Buses : List_Id;
Virtual_Bus : Node_Id;
Implementation : Node_Id;
Property_Node : Node_Id;
Tmp_Node : Node_Id;
VB_Type : Node_Id;
begin
Virtual_Buses := Get_Associated_Virtual_Buses (Port);
if Virtual_Buses = No_List then
return No_Node;
end if;
Tmp_Node := ATN.First_Node (Virtual_Buses);
while Present (Tmp_Node) loop
Virtual_Bus := ATN.Entity (Tmp_Node);
Property_Node := Look_For_Property_In_Declarative
(Virtual_Bus, "implemented_as");
-- Now, we are trying to catch the value of the "Implemented_As"
-- property of the virtual bus. The virtual bus should have
-- a property Implemented_As with an abstract component that
-- describe how the virtual bus is implemented (subprograms, data,
-- ...). Then, we will browse this abstract component to call
-- the right functions.
if Property_Node = No_Node then
exit;
end if;
Implementation := ATN.Entity (ATN.Single_Value (Property_Node));
-- Here, get the type we use to marshall data
VB_Type := Look_For_Subcomponent_In_Declarative
(Implementation, "marshalling_type");
if VB_Type /= No_Node and then
ATN.Default_Instance (VB_Type) /= No_Node then
return ATN.Default_Instance (VB_Type);
end if;
Tmp_Node := ATN.Next_Node (Tmp_Node);
end loop;
return No_Node;
end Get_Instance_Type_Associated_With_Virtual_Bus;
----------------------------------
-- Get_Associated_Virtual_Buses --
----------------------------------
function Get_Associated_Virtual_Buses (Port : Node_Id) return List_Id
is
Port_Spec : Node_Id;
Property_Node : Node_Id;
begin
Port_Spec := Corresponding_Declaration (Port);
Property_Node := Look_For_Property_In_Declarative
(Port_Spec, "allowed_connection_binding_class");
-- We are looking for the Allowed_Connection_Binding_Class
-- on the port. A list of virtual bus should be associated
-- to this port. These virtual buses potentially describe
-- the protocols we use to pack/unpack data before/after
-- network send.
if Property_Node /= No_Node and then
ATN.Expanded_Multi_Value (Property_Node) /= No_List then
return ATN.Expanded_Multi_Value (Property_Node);
else
return No_List;
end if;
end Get_Associated_Virtual_Buses;
---------------------------------------
-- Look_For_Property_In_Declarative --
---------------------------------------
function Look_For_Property_In_Declarative
(Component : Node_Id; Property_Name : String)
return Node_Id
is
use Ocarina.ME_AADL.AADL_Tree.Entities.Properties;
use Ocarina.ME_AADL.AADL_Tree.Nodes;
Tmp : Node_Id;
Property_In_Type : Node_Id := No_Node;
Property_In_Inherited : Node_Id := No_Node;
begin
Tmp := Find_Property_Association_From_Name
(ATN.Properties (Component),
Property_Name,
No_Name);
if Tmp /= No_Node then
return ATN.Property_Association_Value (Tmp);
else
if ATN.Kind (Component) = ATN.K_Component_Implementation then
Property_In_Type := Look_For_Property_In_Declarative
(ATN.Corresponding_Entity
(ATN.Component_Type_Identifier (Component)), Property_Name);
end if;
if (ATN.Kind (Component) = ATN.K_Component_Type or else
ATN.Kind (Component) = ATN.K_Component_Implementation) and then
ATN.Parent (Component) /= No_Node then
Property_In_Inherited := Look_For_Property_In_Declarative
(ATN.Entity (ATN.Parent (Component)), Property_Name);
end if;
end if;
if Property_In_Type /= No_Node then
return Property_In_Type;
end if;
if Property_In_Inherited /= No_Node then
return Property_In_Inherited;
end if;
return No_Node;
end Look_For_Property_In_Declarative;
-------------------------------------------
-- Look_For_Subcomponent_In_Declarative --
-------------------------------------------
function Look_For_Subcomponent_In_Declarative
(Component : Node_Id; Subcomponent_Name : String)
return Node_Id
is
Tmp_Node : Node_Id;
Subcomponent : Node_Id;
Subcomponent_N : Name_Id;
begin
Subcomponent_N := Get_String_Name (Subcomponent_Name);
if not ATU.Is_Empty (ATN.Subcomponents (Component)) then
Tmp_Node := ATN.First_Node (ATN.Subcomponents (Component));
while Present (Tmp_Node) loop
Subcomponent := ATN.Entity (ATN.Entity_Ref (Tmp_Node));
if ATN.Display_Name
(ATN.Identifier (Tmp_Node)) = Subcomponent_N then
return Subcomponent;
end if;
Tmp_Node := ATN.Next_Node (Tmp_Node);
end loop;
end if;
return No_Node;
end Look_For_Subcomponent_In_Declarative;
--------------------------
-- Is_Pure_Device_Port --
--------------------------
function Is_Pure_Device_Port (Port : Node_Id) return Boolean
is
Other_Ports : List_Id;
Tmp : Node_Id;
begin
if Port = No_Node then
return False;
end if;
if not Is_Device (Parent_Component (Port)) then
return False;
end if;
if Is_In (Port) and then Is_Out (Port) then
Display_Error
("Is_Communicating_With_Device does not work on in out port",
Fatal => True);
end if;
if Is_In (Port) then
Other_Ports := Sources (Port);
else
Other_Ports := Destinations (Port);
end if;
Tmp := First_Node (Other_Ports);
while Present (Tmp) loop
if Is_Device (Parent_Component (Item (Tmp))) then
return True;
end if;
Tmp := Next_Node (Tmp);
end loop;
return False;
end Is_Pure_Device_Port;
----------------------------
-- Is_Using_Virtual_Bus --
----------------------------
function Is_Using_Virtual_Bus (Port : Node_Id) return Boolean is
type Browsing_Kind is (By_Source, By_Destination);
function Is_Using_Virtual_Bus_Rec (Port : Node_Id;
Method : Browsing_Kind)
return Boolean is
Source_Port : Node_Id;
Destination_Port : Node_Id;
Tmp : Node_Id;
begin
if Get_Associated_Virtual_Buses (Port) /= No_List then
return True;
end if;
if AAU.Is_Thread (Parent_Component (Port)) then
return False;
end if;
-- We are now in the applicative domain, no need
-- to browse further the component hierarchy.
if Method = By_Source and then
not AAU.Is_Empty (AIN.Sources (Port)) then
Tmp := AIN.First_Node (AIN.Sources (Port));
while Present (Tmp) loop
Source_Port := AIN.Item (Tmp);
if Is_Using_Virtual_Bus_Rec (Source_Port, Method) then
return True;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
if Method = By_Destination and then
not AAU.Is_Empty (AIN.Destinations (Port)) then
Tmp := AIN.First_Node (AIN.Destinations (Port));
while Present (Tmp) loop
Destination_Port := AIN.Item (Tmp);
if Is_Using_Virtual_Bus_Rec (Destination_Port, Method) then
return True;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
return False;
end Is_Using_Virtual_Bus_Rec;
begin
if not AIN.Is_Data (Port) then
raise Program_Error with
"Call to Is_Using_Virtual_Bus with non DATA port";
end if;
if AIN.Is_In (Port) then
return Is_Using_Virtual_Bus_Rec (Port, By_Source);
else
return Is_Using_Virtual_Bus_Rec (Port, By_Destination);
end if;
end Is_Using_Virtual_Bus;
-------------------------------------------
-- Get_Corresponding_Port_In_Component --
-------------------------------------------
function Get_Corresponding_Port_In_Component (Port : Node_Id) return Node_Id
is
function Get_Corresponding_Port_In_Component_Rec
(Port : Node_Id; Parent_Searched : Node_Id; Method : Browsing_Kind)
return Node_Id
is
L : List_Id;
T : Node_Id;
R : Node_Id;
begin
if Parent_Component (Port) = Parent_Searched then
return Port;
end if;
if Method = By_Destination then
L := Destinations (Port);
else
L := Sources (Port);
end if;
if AAU.Is_Empty (L) then
return No_Node;
end if;
T := First_Node (L);
while Present (T) loop
R := Get_Corresponding_Port_In_Component_Rec
(Item (T), Parent_Searched, Method);
if R /= No_Node then
return R;
end if;
T := Next_Node (T);
end loop;
return No_Node;
end Get_Corresponding_Port_In_Component_Rec;
Parent : Node_Id;
Tmp : Node_Id;
R : Node_Id;
L : List_Id;
My_Method : Browsing_Kind;
begin
Parent := Parent_Component (Port);
if Is_In (Port) then
L := Destinations (Port);
My_Method := By_Destination;
else
L := Sources (Port);
My_Method := By_Source;
end if;
if AAU.Is_Empty (L) then
return No_Node;
end if;
Tmp := First_Node (L);
while Present (Tmp) loop
R := Get_Corresponding_Port_In_Component_Rec
(Item (Tmp), Parent, My_Method);
if R /= No_Node then
return R;
end if;
Tmp := Next_Node (Tmp);
end loop;
return No_Node;
end Get_Corresponding_Port_In_Component;
-----------------------------------
-- Process_Use_Default_Sockets --
-----------------------------------
function Process_Use_Defaults_Sockets (The_Process : Node_Id)
return Boolean is
C : Node_Id;
F : Node_Id;
B : Node_Id;
C_End : Node_Id;
End_List : List_Id;
begin
if not AAU.Is_Empty (Features (The_Process)) then
F := First_Node (Features (The_Process));
while Present (F) loop
-- We make two iteration to traverse (1) the sources
-- of F then (2) the destinations of F.
End_List := Sources (F);
for I in Boolean'Range loop
if not AAU.Is_Empty (End_List) then
C_End := First_Node (End_List);
while Present (C_End) loop
-- Get the connection involving C_End
C := Extra_Item (C_End);
-- Get the bus of the connection
B := Get_Bound_Bus (C);
if Get_Transport_API (B, The_Process)
= Transport_BSD_Sockets then
return True;
end if;
C_End := Next_Node (C_End);
end loop;
end if;
End_List := Destinations (F);
end loop;
F := Next_Node (F);
end loop;
end if;
return False;
end Process_Use_Defaults_Sockets;
--------------------------
-- Get_Associated_Bus --
--------------------------
function Get_Associated_Bus (Port : Node_Id)
return Node_Id is
C : Node_Id;
F : Node_Id;
B : Node_Id;
C_End : Node_Id;
End_List : List_Id;
Ports_To_Browse : List_Id;
begin
if Is_In (Port) then
Ports_To_Browse := Sources (Port);
else
Ports_To_Browse := Destinations (Port);
end if;
if not AAU.Is_Empty (Ports_To_Browse) then
F := First_Node (Ports_To_Browse);
while Present (F) loop
-- We make two iteration to traverse (1) the sources
-- of F then (2) the destinations of F.
End_List := Sources (Item (F));
for I in Boolean'Range loop
if not AAU.Is_Empty (End_List) then
C_End := First_Node (End_List);
while Present (C_End) loop
-- Get the connection involving C_End
C := Extra_Item (C_End);
-- Get the bus of the connection
B := Get_Bound_Bus (C);
if B /= No_Node then
return B;
end if;
C_End := Next_Node (C_End);
end loop;
end if;
End_List := Destinations (Item (F));
end loop;
F := Next_Node (F);
end loop;
end if;
return No_Node;
end Get_Associated_Bus;
end Ocarina.Backends.Utils;