----------------------------------------- --------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_HI_ADA.MAPPING -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, 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 Namet; use Namet; with Utils; use Utils; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Generators.Utils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.PO_HI_Ada.Runtime; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_HI_Ada.Mapping is use Ocarina.Nodes; use Ocarina.Generators.Utils; use Ocarina.Generators.Ada_Tree.Nodes; use Ocarina.Generators.Ada_Tree.Nutils; use Ocarina.Generators.PO_HI_Ada.Runtime; use Ocarina.Generators.Ada_Values; package AAN renames Ocarina.Nodes; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; --------------------------- -- Bind_AADL_To_Activity -- --------------------------- procedure Bind_AADL_To_Activity (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Activity_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Activity; ----------------------------- -- Bind_AADL_To_Deployment -- ----------------------------- procedure Bind_AADL_To_Deployment (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Deployment_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Deployment; ----------------------------- -- Bind_AADL_To_Enumerator -- ----------------------------- procedure Bind_AADL_To_Enumerator (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Enumerator_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Enumerator; ---------------------- -- Bind_AADL_To_Job -- ---------------------- procedure Bind_AADL_To_Job (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Job_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Job; ----------------------- -- Bind_AADL_To_Main -- ----------------------- procedure Bind_AADL_To_Main (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Main_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Main; --------------------------- -- Bind_AADL_To_Marshall -- --------------------------- procedure Bind_AADL_To_Marshall (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Marshall_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Marshall; ------------------------------ -- Bind_AADL_To_Marshallers -- ------------------------------ procedure Bind_AADL_To_Marshallers (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Marshallers_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Marshallers; ------------------------- -- Bind_AADL_To_Naming -- ------------------------- procedure Bind_AADL_To_Naming (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Naming_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Naming; ------------------------- -- Bind_AADL_To_Object -- ------------------------- procedure Bind_AADL_To_Object (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Object_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Object; -------------------------- -- Bind_AADL_To_Deliver -- -------------------------- procedure Bind_AADL_To_Deliver (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Deliver_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Deliver; ------------------------------------- -- Bind_AADL_To_Feature_Subprogram -- ------------------------------------- procedure Bind_AADL_To_Feature_Subprogram (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Feature_Subprogram_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Feature_Subprogram; ----------------------------- -- Bind_AADL_To_Subprogram -- ----------------------------- procedure Bind_AADL_To_Subprogram (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Subprogram_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Subprogram; ------------------------------ -- Bind_AADL_To_Subprograms -- ------------------------------ procedure Bind_AADL_To_Subprograms (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Subprograms_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Subprograms; ---------------------------------- -- Bind_AADL_To_Type_Definition -- ---------------------------------- procedure Bind_AADL_To_Type_Definition (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Type_Definition_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Type_Definition; -------------------------------- -- Bind_AADL_To_Default_Value -- -------------------------------- procedure Bind_AADL_To_Default_Value (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Default_Value_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Default_Value; --------------------------------- -- Bind_AADL_To_Port_Interface -- --------------------------------- procedure Bind_AADL_To_Port_Interface (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Port_Interface_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Port_Interface; ----------------------------------- -- Bind_AADL_To_Port_Enumeration -- ----------------------------------- procedure Bind_AADL_To_Port_Enumeration (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Port_Enumeration_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Port_Enumeration; ------------------------ -- Bind_AADL_To_Types -- ------------------------ procedure Bind_AADL_To_Types (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Types_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Types; ----------------------------- -- Bind_AADL_To_Unmarshall -- ----------------------------- procedure Bind_AADL_To_Unmarshall (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Unmarshall_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Unmarshall; ---------------------------- -- Bind_AADL_To_Put_Value -- ---------------------------- procedure Bind_AADL_To_Put_Value (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Put_Value_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Put_Value; ---------------------------- -- Bind_AADL_To_Get_Value -- ---------------------------- procedure Bind_AADL_To_Get_Value (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Get_Value_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Get_Value; ---------------------------- -- Bind_AADL_To_Get_Count -- ---------------------------- procedure Bind_AADL_To_Get_Count (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Get_Count_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Get_Count; ----------------------------- -- Bind_AADL_To_Next_Value -- ----------------------------- procedure Bind_AADL_To_Next_Value (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Next_Value_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Next_Value; --------------------------------- -- Map_Distributed_Application -- --------------------------------- function Map_Distributed_Application (E : node_id) return node_id is D : constant node_id := New_Node (ADN.k_hi_distributed_application); begin pragma assert (Is_System (E)); -- Update the global variable to be able to fetch the root of -- the distributed application and generate the source files. HI_Distributed_Application_Root := D; ADN.Set_Name (D, To_Ada_Name (AAN.Name (AAN.Identifier (E)))); ADN.Set_Units (D, New_List (ADN.k_list_id)); ADN.Set_HI_Nodes (D, New_List (ADN.k_list_id)); return D; end Map_Distributed_Application; ----------------- -- Map_HI_Node -- ----------------- function Map_HI_Node (E : node_id) return node_id is N : constant node_id := New_Node (ADN.k_hi_node); begin pragma assert (Is_Process (E)); -- The name of the node is not the name of the process -- component instance, but the name of the process subcomponent -- corresponding to this instance. ADN.Set_Name (N, To_Ada_Name (AAN.Name (AAN.Identifier (AAN.Parent_Subcomponent (E))))); Set_Units (N, New_List (k_list_id)); -- Append the partition N to the node list of the PolyORB-HI -- distributed application. We are sure that the top of the -- entity stack contains the Ada distrubuted application node. Append_Node_To_List (N, HI_Nodes (Current_Entity)); Set_Distributed_Application (N, Current_Entity); return N; end Map_HI_Node; ----------------- -- Map_HI_Unit -- ----------------- function Map_HI_Unit (E : node_id) return node_id is U : node_id; L : list_id; N : node_id; P : node_id; Ada_Name : name_id; begin pragma assert (Is_Process (E)); U := New_Node (ADN.k_hi_unit, AAN.Identifier (E)); L := New_List (k_packages); Set_Packages (U, L); Ada_Name := To_Ada_Name (AAN.Display_Name (AAN.Identifier (AAN.Parent_Subcomponent (E)))); -- The 'Naming' package N := Defining_Identifier (RU (ru_naming, False)); P := Make_Package_Declaration (N); Set_File_Name (P, Add_Suffix_To_Name ("_naming", To_Lower (Ada_Name))); Set_Has_Custom_File_Name (P, True); Set_Distributed_Application_Unit (P, U); Set_Naming_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Naming (Identifier (E), P); -- The 'Deployment' package N := Defining_Identifier (RU (ru_deployment, False)); P := Make_Package_Declaration (N); Set_File_Name (P, Add_Suffix_To_Name ("_deployment", To_Lower (Ada_Name))); Set_Has_Custom_File_Name (P, True); Set_Distributed_Application_Unit (P, U); Set_Deployment_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Deployment (Identifier (E), P); -- The 'Types' package N := Defining_Identifier (RU (ru_types, False)); P := Make_Package_Declaration (N); Set_File_Name (P, Add_Suffix_To_Name ("_types", To_Lower (Ada_Name))); Set_Has_Custom_File_Name (P, True); Set_Distributed_Application_Unit (P, U); Set_Types_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Types (Identifier (E), P); -- The 'Marshallers' package N := Defining_Identifier (RU (ru_marshallers, False)); P := Make_Package_Declaration (N); Set_File_Name (P, Add_Suffix_To_Name ("_marshallers", To_Lower (Ada_Name))); Set_Has_Custom_File_Name (P, True); Set_Distributed_Application_Unit (P, U); Set_Marshallers_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Marshallers (Identifier (E), P); -- The 'Subprograms' package N := Defining_Identifier (RU (ru_subprograms, False)); P := Make_Package_Declaration (N); Set_File_Name (P, Add_Suffix_To_Name ("_subprograms", To_Lower (Ada_Name))); Set_Has_Custom_File_Name (P, True); Set_Distributed_Application_Unit (P, U); Set_Subprograms_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Subprograms (Identifier (E), P); -- The 'Activity' package Get_Name_String (Ada_Name); Add_Str_To_Name_Buffer ("_Activity"); N := Make_Defining_Identifier (Name_Find); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Activity_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Activity (Identifier (E), P); -- Main suprogram P := Make_Main_Subprogram_Implementation (Make_Defining_Identifier (Ada_Name)); Set_Distributed_Application_Unit (P, U); Set_Main_Subprogram (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Main (Identifier (E), P); -- Append the Unit to the units list of the current Ada -- partition. Append_Node_To_List (U, Units (Current_Entity)); ADN.Set_Entity (U, Current_Entity); return U; end Map_HI_Unit; ------------------ -- Map_Ada_Time -- ------------------ function Map_Ada_Time (T : time_type) return node_id is Time : unsigned_long_long; S : node_id; begin case T.U is when picosecond => -- If we can convert it into nanosecond, we are -- OK. Otherwise this is an error because Ada.Real_Time -- does not support picoseconds if T.T mod 1000 = 0 then Time := T.T / 1000; S := RE (re_nanoseconds); else return No_Node; end if; when nanosecond => Time := T.T; S := RE (re_nanoseconds); when microsecond => Time := T.T; S := RE (re_microseconds); when millisecond => Time := T.T; S := RE (re_milliseconds); when second => Time := T.T; S := RE (re_seconds); when minute => Time := T.T; S := RE (re_minutes); when hour => -- Convert it into minutes Time := T.T * 60; S := RE (re_minutes); end case; return Make_Subprogram_Call (S, Make_List_Id (Make_Literal (New_Integer_Value (Time, 1, 10)))); end Map_Ada_Time; ---------------------- -- Map_Ada_Priority -- ---------------------- function Map_Ada_Priority (P : unsigned_long_long) return node_id is AADL_Delta : constant unsigned_long_long := Get_Max_Priority - Get_Min_Priority; System_PF : constant node_id := Make_Attribute_Designator (RE (re_priority), a_first); System_PL : constant node_id := Make_Attribute_Designator (RE (re_priority), a_last); Result : node_id; begin -- ------------------------------------------------------- -- ^ ^ ^ -- Min_AADL X_AADL Max_AADL -- ------------------------------------------------------- -- ^ ^ ^ -- Min_Ada X_Ada Max_Ada -- X_Ada = Min_Ada + (X_AADL - Min_AADL) * (Max_Ada - Min_Ada) -- ________________________________________ -- (Max_AADL - Min_AADL) -- (X_AADL - Min_AADL) Result := Make_Expression (Make_Literal (New_Integer_Value (P, 1, 10)), op_minus, Make_Literal (New_Integer_Value (Get_Min_Priority, 1, 10))); -- ... * (Max_Ada - Min_Ada) Result := Make_Expression (Result, op_asterisk, Make_Expression (System_PL, op_minus, System_PF)); -- ... / (Max_AADL - Min_AADL) Result := Make_Expression (Result, op_slash, Make_Literal (New_Integer_Value (AADL_Delta, 1, 10))); -- Min_Ada + ... Result := Make_Expression (System_PF, op_plus, Result); return Result; end Map_Ada_Priority; -------------------------- -- Map_Marshallers_Name -- -------------------------- function Map_Marshallers_Name (E : node_id) return name_id is begin pragma assert (Is_Process (E) or else Utils.Is_Data (E)); if Is_Process (E) then -- Get the subcomponent name to have coherent naming Get_Name_String (To_Ada_Name (AAN.Display_Name (Identifier (Parent_Subcomponent (E))))); else Get_Name_String (To_Ada_Name (AAN.Display_Name (Identifier (E)))); end if; Add_Str_To_Name_Buffer ("_Marshallers"); return Name_Find; end Map_Marshallers_Name; ----------------------------- -- Map_Task_Job_Identifier -- ----------------------------- function Map_Task_Job_Identifier (E : node_id) return node_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Job"); return Make_Defining_Identifier (Name_Find); end Map_Task_Job_Identifier; ------------------------- -- Map_Task_Identifier -- ------------------------- function Map_Task_Identifier (E : node_id) return node_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Task"); return Make_Defining_Identifier (Name_Find); end Map_Task_Identifier; ------------------------------- -- Map_Port_Enumeration_Name -- ------------------------------- function Map_Port_Enumeration_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E) or else Is_Subprogram (E)); if Is_Thread (E) then Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); else Get_Name_String (To_Ada_Name (Display_Name (Identifier (E)))); end if; Add_Str_To_Name_Buffer ("_Port_Type"); return Name_Find; end Map_Port_Enumeration_Name; ----------------------------- -- Map_Port_Interface_Name -- ----------------------------- function Map_Port_Interface_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E) or else Is_Subprogram (E)); if Is_Thread (E) then Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); else Get_Name_String (To_Ada_Name (Display_Name (Identifier (E)))); end if; Add_Str_To_Name_Buffer ("_Interface"); return Name_Find; end Map_Port_Interface_Name; -------------------------- -- Map_Port_Status_Name -- -------------------------- function Map_Port_Status_Name (E : node_id) return name_id is begin pragma assert (Is_Subprogram (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_Status"); return Name_Find; end Map_Port_Status_Name; -------------------------- -- Map_Port_Enumeration -- -------------------------- function Map_Port_Enumeration (E : node_id) return node_id is Enumerators : constant list_id := New_List (ADN.k_enumeration_literals); F : node_id; begin if not AAU.Is_Empty (Features (E)) then F := AAN.First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then Append_Node_To_List (Map_Ada_Defining_Identifier (F), Enumerators); end if; F := AAN.Next_Node (F); end loop; end if; if Is_Empty (Enumerators) then return No_Node; else return Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Type_Definition => Make_Enumeration_Type_Definition (Enumerators)); end if; end Map_Port_Enumeration; ------------------------ -- Map_Port_Interface -- ------------------------ function Map_Port_Interface (E : node_id) return node_id is Variants : constant list_id := New_List (ADN.k_variant_list); Variant : node_id; Choice : node_id; Component : node_id; F : node_id; N : node_id; begin if not AAU.Is_Empty (Features (E)) then F := AAN.First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then -- Create a variant with a choice corresponding to -- the enumerator mapped from the port and with a -- component having the type of the port (if it is -- a data port). Variant := New_Node (ADN.k_variant); Append_Node_To_List (Variant, Variants); Choice := Map_Ada_Defining_Identifier (F); ADN.Set_Discrete_Choices (Variant, Make_List_Id (Choice)); if AAN.Is_Data (F) then Component := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Ada_Component_Name (F)), Subtype_Indication => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); ADN.Set_Component_List (Variant, Make_List_Id (Component)); end if; end if; F := AAN.Next_Node (F); end loop; end if; if Is_Empty (Variants) then return No_Node; else N := Make_Variant_Part (Discriminant => Make_Defining_Identifier (CN (c_port)), Variant_List => Variants); N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Port_Interface_Name (E)), Discriminant_Spec => Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (CN (c_port)), Subtype_Indication => Make_Defining_Identifier (Map_Port_Enumeration_Name (E)), Expression => Make_Attribute_Designator (Make_Designator (Map_Port_Enumeration_Name (E)), a_first)), Type_Definition => Make_Record_Type_Definition (Make_Record_Definition (Make_List_Id (N)))); return N; end if; end Map_Port_Interface; --------------------- -- Map_Port_Status -- --------------------- function Map_Port_Status (E : node_id; Full_Declaration : Boolean) return node_id is Component_List : list_id; F : node_id; N : node_id; begin -- FIXME: this implementation assumes that the sise of the -- FIFOs is 1. we shoulds use arrays of the size of each FIFO. F := AAN.First_Node (Features (E)); if Full_Declaration then Component_List := New_List (ADN.k_component_list); while Present (F) loop if Kind (F) = k_port_spec_instance then -- For each port, we declare a boolean component to -- indicate whether the port is triggered or not. N := Make_Component_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (F), Subtype_Indication => RE (re_boolean), Expression => RE (re_false)); Append_Node_To_List (N, Component_List); -- If the port is an event data port, we add a -- component having the type of the port. if AAN.Is_Data (F) then N := Make_Component_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Ada_Component_Name (F)), Subtype_Indication => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); Append_Node_To_List (N, Component_List); end if; end if; F := AAN.Next_Node (F); end loop; N := Make_Record_Type_Definition (Make_Record_Definition (Component_List)); else N := Make_Private_Type_Definition; end if; N := Make_Full_Type_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Port_Status_Name (E)), Type_Definition => N); return N; end Map_Port_Status; ------------------------------ -- Map_Node_Name_Identifier -- ------------------------------ function Map_Node_Name_Identifier (E : node_id) return node_id is begin pragma assert (Kind (E) = k_subcomponent_instance); Get_Name_String (To_Ada_Name (Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_Node_Name"); return Make_Defining_Identifier (Name_Find); end Map_Node_Name_Identifier; ---------------------------- -- Map_Integer_Array_Name -- ---------------------------- function Map_Integer_Array_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Integer_Array"); return Name_Find; end Map_Integer_Array_Name; ---------------------------- -- Map_Address_Array_Name -- ---------------------------- function Map_Address_Array_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Address_Array"); return Name_Find; end Map_Address_Array_Name; ------------------------- -- Map_FIFO_Sizes_Name -- ------------------------- function Map_FIFO_Sizes_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_FIFO_Sizes"); return Name_Find; end Map_FIFO_Sizes_Name; ---------------------- -- Map_Offsets_Name -- ---------------------- function Map_Offsets_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Offsets"); return Name_Find; end Map_Offsets_Name; ------------------------- -- Map_Total_Size_Name -- ------------------------- function Map_Total_Size_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Total_FIFO_Size"); return Name_Find; end Map_Total_Size_Name; -------------------------- -- Map_Destination_Name -- -------------------------- function Map_Destination_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E) or else Kind (E) = k_port_spec_instance); if Is_Thread (E) then Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); else declare Thread_Name : constant name_id := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Port_Name : constant name_id := To_Ada_Name (Display_Name (Identifier (E))); begin Get_Name_String (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); end; end if; Add_Str_To_Name_Buffer ("_Destinations"); return Name_Find; end Map_Destination_Name; ---------------------------- -- Map_N_Destination_Name -- ---------------------------- function Map_N_Destination_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_N_Destinations"); return Name_Find; end Map_N_Destination_Name; ---------------------------- -- Map_Interrogators_Name -- ---------------------------- function Map_Interrogators_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Interrogators"); return Name_Find; end Map_Interrogators_Name; ---------------------- -- Map_Deliver_Name -- ---------------------- function Map_Deliver_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Deliver"); return Name_Find; end Map_Deliver_Name; -------------------------------- -- Map_Modes_Enumeration_Name -- -------------------------------- function Map_Modes_Enumeration_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Mode_Type"); return Name_Find; end Map_Modes_Enumeration_Name; --------------------------- -- Map_Current_Mode_Name -- --------------------------- function Map_Current_Mode_Name (E : node_id) return name_id is begin pragma assert (Is_Thread (E)); Get_Name_String (To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E))))); Add_Str_To_Name_Buffer ("_Current_Mode"); return Name_Find; end Map_Current_Mode_Name; ------------------- -- Need_Delivery -- ------------------- function Need_Delivery (E : node_id) return Boolean is Result : Boolean := Has_In_Ports (E); S : node_id; begin pragma assert (Is_Process (E)); if not AAU.Is_Empty (Subcomponents (E)) then S := AAN.First_Node (Subcomponents (E)); while Present (S) and then not Result loop if Is_Thread (Corresponding_Instance (S)) then Result := Result or else Has_In_Ports (Corresponding_Instance (S)); end if; S := AAN.Next_Node (S); end loop; end if; return Result; end Need_Delivery; end Ocarina.Generators.PO_HI_Ada.Mapping;