------------------------------------------- ------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P O _ H I _ C . M A P P I N G -- -- -- -- B o d y -- -- -- -- Copyright (C) 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.Messages; with Ocarina.Generators.Utils; with Ocarina.Generators.C_Values; with Ocarina.Generators.C_Tree.Nodes; with Ocarina.Generators.C_Tree.Nutils; with Ocarina.Generators.PO_HI_C.Runtime; package body Ocarina.Generators.PO_HI_C.Mapping is use Ocarina.Nodes; use Ocarina.Generators.Messages; use Ocarina.Generators.Utils; use Ocarina.Generators.C_Values; use Ocarina.Generators.C_Tree.Nodes; use Ocarina.Generators.C_Tree.Nutils; use Ocarina.Generators.PO_HI_C.Runtime; package AAN renames Ocarina.Nodes; package AAU renames Ocarina.Nutils; package CTN renames Ocarina.Generators.C_Tree.Nodes; package CTU renames Ocarina.Generators.C_Tree.Nutils; --------------------------- -- Call_Remote_Functions -- --------------------------- procedure Call_Remote_Functions (Caller_Thread : Node_Id; Spg_Call : Node_Id; Declarations : List_Id; Statements : List_Id) is procedure Check_Connection_Consistency (F : Node_Id); -- Verifies that the feature F is connected to at least one -- destination. procedure Call_Remote_Functions (Root_F : Node_Id; Intermediate_F : Node_Id); -- This recursive procedure will unwind recursively all the -- destinations of the Root_F feature until it finds a -- subprogram. If the remote subprogram is found, add a call -- to the subprogram call table (if necessary) and add a -- parameter association corresponding to Root_F the the -- call to this subprogram. At the top level call to -- Call_Remote_Subprograms, Intermediate_F = Root_F. procedure Update_Remote_Calls (Remote_Spg : Node_Id; Param_Value : Node_Id); -- If the call to Spg has not been added yet, create -- it. Adds a parameter association Param_Name => -- Param_Value to the call profile. Call_List : constant List_Id := New_List (CTN.K_Statement_List); -- List that contains the calls to all remote subprogram -- connected to Spg. ---------------------------------- -- Check_Connection_Consistency -- ---------------------------------- procedure Check_Connection_Consistency (F : Node_Id) is begin if AAU.Length (Destinations (F)) = 0 then Display_Located_Error (AAN.Loc (F), "This feature does not have any destinations", Fatal => True); end if; end Check_Connection_Consistency; ----------------------------- -- Call_Remote_Subprograms -- ----------------------------- procedure Call_Remote_Functions (Root_F : Node_Id; Intermediate_F : Node_Id) is Destination_F : Node_Id; C : Node_Id; begin -- Root F has to be a parameter instance pragma Assert (Kind (Root_F) = K_Parameter_Instance); -- The container of the subprogram containing F has to be -- necessarily a Thread. pragma Assert (Is_Thread (Parent_Component (Parent_Sequence (Parent_Subcomponent (Parent_Component (Root_F)))))); -- Check the feature consistency Check_Connection_Consistency (Intermediate_F); Destination_F := AAN.First_Node (Destinations (Intermediate_F)); while Present (Destination_F) loop C := Parent_Component (Item (Destination_F)); -- If C is also the parent component of Root_F (which -- is necessarily a subprogram). Then display an error -- and exit. if C = Parent_Component (Root_F) then Display_Located_Error (AAN.Loc (C), "This subprogram is involved in a connection cycle", Fatal => True); end if; if Is_Subprogram (C) then -- If C is a subprogram, then append it to the call -- list (if necessary, and add a parameter -- association corresponding to Root_F and -- Destination_F. Update_Remote_Calls (C, Root_F); else -- Otherwise, keep unwinding the destinations Call_Remote_Functions (Root_F, Item (Destination_F)); end if; Destination_F := AAN.Next_Node (Destination_F); end loop; end Call_Remote_Functions; ------------------------- -- Update_Remote_Calls -- ------------------------- procedure Update_Remote_Calls (Remote_Spg : Node_Id; Param_Value : Node_Id) is R_Name : Name_Id; N : Node_Id; Profile : List_Id; begin -- Check whether a call corresponding to Spg has already -- been added to Call_List (we use name table infos -- instead of looping on Call list, which is a very fast -- way. Set_Nat_To_Name_Buffer (Nat (Remote_Spg)); Add_Str_To_Name_Buffer ("%RemoteCall%"); Add_Nat_To_Name_Buffer (Nat (Spg_Call)); R_Name := Name_Find; if Get_Name_Table_Info (R_Name) = 0 then N := Message_Comment ("Call stub "); Append_Node_To_List (N, Statements); Profile := New_List (CTN.K_List_Id); -- Add the FROM argument (first argument) N := Make_Defining_Identifier (Map_C_Enumerator_Name (Parent_Subcomponent (Caller_Thread), Entity => True)); Append_Node_To_List (N, Profile); -- Add the TO argument (second argument) N := Make_Defining_Identifier (Map_C_Enumerator_Name (Parent_Subcomponent (Get_Container_Thread (Remote_Spg)), Entity => True)); Append_Node_To_List (N, Profile); -- Add the message argument (third argument) N := Make_Variable_Address (Make_Defining_Identifier (PN (P_Message))); Append_Node_To_List (N, Profile); -- Create the subprogram call N := Make_Call_Profile (Map_Stub_Identifier (Remote_Spg), Profile); Append_Node_To_List (N, Statements); -- Mark the call as being added. The info we associate -- to the name is the value of the profile list to be -- able to get it to add parameter associations. Set_Name_Table_Info (R_Name, Nat (Profile)); else Profile := List_Id (Get_Name_Table_Info (R_Name)); end if; N := Make_Defining_Identifier (Map_C_Full_Parameter_Name (Spg_Call, Param_Value)); Append_Node_To_List (N, Profile); end Update_Remote_Calls; Spg : constant Node_Id := Corresponding_Instance (Spg_Call); F : Node_Id; begin pragma Assert (Is_Thread (Caller_Thread)); -- 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 Get_Remote_Subprogram"; end if; if not AAU.Is_Empty (Features (Spg)) then F := AAN.First_Node (Features (Spg)); while Present (F) loop if Kind (F) = K_Parameter_Instance and then Is_Out (F) then -- Call all the remote subprograms connected the -- feature F. Call_Remote_Functions (F, F); end if; F := AAN.Next_Node (F); end loop; end if; -- Append the calls to the Statements list if not CTU.Is_Empty (Call_List) then Append_Node_To_List (CTN.First_Node (Call_List), Statements); end if; end Call_Remote_Functions; --------------------------------- -- Map_Distributed_Application -- --------------------------------- function Map_Distributed_Application (E : Node_Id) return Node_Id is D : constant Node_Id := New_Node (CTN.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; CTN.Set_Name (D, To_C_Name (AAN.Name (AAN.Identifier (E)))); CTN.Set_Units (D, New_List (CTN.K_List_Id)); CTN.Set_HI_Nodes (D, New_List (CTN.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 (CTN.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. CTN.Set_Name (N, To_C_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; S : List_Id; H : List_Id; N : Node_Id; P : Node_Id; begin pragma Assert (Is_System (E) or else Is_Process (E)); U := New_Node (CTN.K_HI_Unit, AAN.Identifier (E)); S := New_List (K_Sources); H := New_List (K_Headers); -- Packages that are common to all nodes if Is_Process (E) then Set_Str_To_Name_Buffer ("deployment"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Deployment_Source (U, P); Append_Node_To_List (P, S); Set_Str_To_Name_Buffer ("subprograms"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Subprograms_Source (U, P); Append_Node_To_List (P, S); Set_Str_To_Name_Buffer ("types"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Types_Source (U, P); Append_Node_To_List (P, S); Set_Str_To_Name_Buffer ("marshallers"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Marshallers_Source (U, P); Append_Node_To_List (P, S); Set_Str_To_Name_Buffer ("request"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Request_Source (U, P); Append_Node_To_List (P, S); Set_Str_To_Name_Buffer ("activity"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Activity_Source (U, P); Append_Node_To_List (P, S); Bind_AADL_To_Activity (Identifier (E), P); Set_Str_To_Name_Buffer ("naming"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Naming_Source (U, P); Append_Node_To_List (P, S); Bind_AADL_To_Naming (Identifier (E), P); Set_Str_To_Name_Buffer ("activity"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Activity_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("main"); N := Make_Defining_Identifier (Name_Find); P := Make_Source_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Main_Source (U, P); Append_Node_To_List (P, S); Bind_AADL_To_Main (Identifier (E), P); Set_Str_To_Name_Buffer ("deployment"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Deployment_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("request"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Request_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("types"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Types_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("marshallers"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Marshallers_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("subprograms"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Subprograms_Header (U, P); Append_Node_To_List (P, H); Set_Str_To_Name_Buffer ("naming"); N := Make_Defining_Identifier (Name_Find); P := Make_Header_File (N); Set_Distributed_Application_Unit (P, U); CTN.Set_Naming_Header (U, P); Append_Node_To_List (P, H); end if; -- Append the Unit to the units list of the current Ada -- partition. CTN.Set_Sources (U, S); CTN.Set_Headers (U, H); Append_Node_To_List (U, Units (Current_Entity)); CTN.Set_Entity (U, Current_Entity); return U; end Map_HI_Unit; ------------------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Feature_Subprogram_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Feature_Subprogram; ----------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Deployment_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Deployment; ------------------------------ -- Bind_AADL_To_Global_Port -- ------------------------------ procedure Bind_AADL_To_Global_Port (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Global_Port_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Global_Port; ----------------------------- -- Bind_AADL_To_Local_Port -- ----------------------------- procedure Bind_AADL_To_Local_Port (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Local_Port_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Local_Port; -------------------------- -- Bind_AADL_To_Request -- -------------------------- procedure Bind_AADL_To_Request (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Request_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Request; --------------------------- -- Bind_AADL_To_Entities -- --------------------------- procedure Bind_AADL_To_Entities (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Entities_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Entities; -------------------------- -- Bind_AADL_To_Servers -- -------------------------- procedure Bind_AADL_To_Servers (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Servers_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Servers; ----------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Subprogram_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Subprogram; --------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Activity_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Activity; ------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Naming_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Naming; ---------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Job_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Job; ----------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Enumerator_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Enumerator; ---------------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Type_Definition_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Type_Definition; ---------------------------------- -- Bind_AADL_To_Process_Request -- ---------------------------------- procedure Bind_AADL_To_Process_Request (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Process_Request_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Process_Request; ------------------------------- -- Bind_AADL_To_Request_Type -- ------------------------------- procedure Bind_AADL_To_Request_Type (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Request_Type_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Request_Type; ----------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Main_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Main; ----------------------------- -- Map_Task_Job_Identifier -- ----------------------------- function Map_Task_Job_Identifier (E : Node_Id) return Node_Id is Name : Name_Id; begin Get_Name_String (To_C_Name (AAN.Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_job"); Name := Name_Find; Name := To_Lower (Name); return Make_Defining_Identifier (Name); end Map_Task_Job_Identifier; --------------------------------- -- Map_Task_Deliver_Identifier -- --------------------------------- function Map_Task_Deliver_Identifier (E : Node_Id) return Node_Id is Name : Name_Id; begin Get_Name_String (To_C_Name (AAN.Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_deliver"); Name := Name_Find; Name := To_Lower (Name); return Make_Defining_Identifier (Name); end Map_Task_Deliver_Identifier; -------------- -- Map_Time -- -------------- function Map_Time (T : Time_Type) return Node_Id is Time : Unsigned_Long_Long; S : Node_Id; begin case T.U is when Picosecond => -- Our framework only support microseconds -- Picosecond and Nanosecond are ignored if T.T mod 1000000 = 0 then Time := T.T / 1000000; S := RE (RE_Microseconds); else return No_Node; end if; when Nanosecond => if T.T mod 1000 = 0 then Time := T.T / 1000; S := RE (RE_Microseconds); else return No_Node; end if; S := RE (RE_Microseconds); 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_Call_Profile (S, Make_List_Id (Make_Literal (New_Int_Value (Time, 1, 10)))); end Map_Time; --------------------------- -- Map_C_Enumerator_Name -- --------------------------- function Map_C_Enumerator_Name (E : Node_Id; Entity : Boolean := False; Server : Boolean := False; Port_Type : Boolean := False; Local_Port : Boolean := False) return Name_Id is Ada_Name_1 : Name_Id; Ada_Name_2 : Name_Id; begin if Kind (E) = K_Port_Spec_Instance then Ada_Name_1 := CTU.To_C_Name (Display_Name (Identifier (E))); Get_Name_String (CTU.To_C_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E)))))); if Local_Port then Add_Str_To_Name_Buffer ("_local_"); Get_Name_String_And_Append (Ada_Name_1); else Add_Str_To_Name_Buffer ("_global_"); Get_Name_String_And_Append (Ada_Name_1); end if; elsif Is_Subprogram (E) or else (Present (Corresponding_Instance (E)) and then Is_Process (Corresponding_Instance (E))) then -- For subprograms and processes, the enemerator name is -- mapped from the entity name. Get_Name_String (CTU.To_C_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 name and the thread subcomponent name. -- Verifiy that the thread is a subcomponent of a process pragma Assert (Is_Process (Parent_Component (E))); Ada_Name_1 := CTU.To_C_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Ada_Name_2 := CTU.To_C_Name (Display_Name (Identifier (E))); if Port_Type then Set_Str_To_Name_Buffer ("__po_hi_"); Get_Name_String_And_Append (Ada_Name_2); Add_Str_To_Name_Buffer ("_t"); else 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"); end if; if Server then Add_Str_To_Name_Buffer ("_server"); end if; if Entity then Add_Str_To_Name_Buffer ("_entity"); end if; else raise Program_Error with "Wrong node kind for Map_C_Enumerator_Name"; end if; Ada_Name_1 := Name_Find; Ada_Name_1 := To_Lower (Ada_Name_1); return Ada_Name_1; end Map_C_Enumerator_Name; ----------------------- -- Map_C_Define_Name -- ----------------------- function Map_C_Define_Name (E : Node_Id; Nb_Ports : Boolean := False) return Name_Id is Ada_Name : Name_Id; begin if Is_Thread (Corresponding_Instance (E)) then -- For threads, the enumerator name is mapped from the -- containing process name and the thread subcomponent name. -- Verifiy that the thread is a subcomponent of a process pragma Assert (Is_Process (Parent_Component (E))); Ada_Name := Display_Name (Identifier (E)); Set_Str_To_Name_Buffer ("__PO_HI_"); Get_Name_String_And_Append (Ada_Name); if Nb_Ports then Add_Str_To_Name_Buffer ("_NB_PORTS"); end if; else raise Program_Error with "Wrong node kind for Map_C_Enumerator_Name"; end if; Ada_Name := Name_Find; Ada_Name := To_Upper (Ada_Name); return Ada_Name; end Map_C_Define_Name; ------------------------- -- Map_C_Variable_Name -- ------------------------- function Map_C_Variable_Name (E : Node_Id; Port_Variable : Boolean := False; Port_History : Boolean := False; Port_Woffsets : Boolean := False; Port_Empties : Boolean := False; Port_First : Boolean := False; Port_Queue : Boolean := False; Port_Recent : Boolean := False; Port_Fifo_Size : Boolean := False; Port_Offsets : Boolean := False; Port_Used_Size : Boolean := False; Port_N_Dest : Boolean := False; Port_Local_Dest : Boolean := False; Port_Destinations : Boolean := False; Port_Total_Fifo : Boolean := False; Port_Request : Boolean := False; Request_Variable : Boolean := False) return Name_Id is Ada_Name : Name_Id; begin Ada_Name := To_C_Name (Display_Name (Identifier (E))); if not Port_Request and then not Request_Variable then Set_Str_To_Name_Buffer ("__po_hi_"); Get_Name_String_And_Append (Ada_Name); else Get_Name_String (Ada_Name); end if; if Port_Variable then Add_Str_To_Name_Buffer ("_local_to_global"); elsif Port_History then Add_Str_To_Name_Buffer ("_history"); elsif Port_Woffsets then Add_Str_To_Name_Buffer ("_woffsets"); elsif Port_Empties then Add_Str_To_Name_Buffer ("_empties"); elsif Port_First then Add_Str_To_Name_Buffer ("_first"); elsif Port_Queue then Add_Str_To_Name_Buffer ("_queue"); elsif Port_Recent then Add_Str_To_Name_Buffer ("_recent"); elsif Port_Fifo_Size then Add_Str_To_Name_Buffer ("_fifo_size"); elsif Port_Offsets then Add_Str_To_Name_Buffer ("_offsets"); elsif Port_Used_Size then Add_Str_To_Name_Buffer ("_used_size"); elsif Port_N_Dest then Add_Str_To_Name_Buffer ("_n_dest"); elsif Port_Local_Dest then Add_Str_To_Name_Buffer ("_local_destinations"); elsif Port_Destinations then Add_Str_To_Name_Buffer ("_destinations"); elsif Port_Total_Fifo then Add_Str_To_Name_Buffer ("_total_fifo_size"); elsif Port_Request then Add_Str_To_Name_Buffer ("_request"); elsif Request_Variable then Add_Str_To_Name_Buffer ("_request_var"); end if; Ada_Name := Name_Find; return Ada_Name; end Map_C_Variable_Name; -------------------------- -- Map_C_Operation_Name -- -------------------------- function Map_C_Operation_Name (E : Node_Id) return Name_Id is Ada_Name : Name_Id; begin Get_Name_String (CTU.To_C_Name (Display_Name (Identifier (E)))); Ada_Name := Name_Find; return Ada_Name; end Map_C_Operation_Name; ------------------------------- -- Map_C_Full_Parameter_Name -- ------------------------------- function Map_C_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 (AAU.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))); Get_Name_String (CTU.To_C_Name (Name_Find)); if Suffix /= ASCII.NUL then Add_Str_To_Name_Buffer ('_' & Suffix); end if; return Name_Find; end Map_C_Full_Parameter_Name; -------------------------- -- Map_C_Port_Data_Name -- -------------------------- function Map_C_Port_Data_Name (E : Node_Id; P : Node_Id) return Name_Id is begin Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E, True)); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Display_Name (Identifier (P))); Get_Name_String (CTU.To_C_Name (Name_Find)); return Name_Find; end Map_C_Port_Data_Name; -------------------------------- -- Map_C_Data_Type_Designator -- -------------------------------- function Map_C_Data_Type_Designator (E : Node_Id) return Node_Id is begin Add_Include (RH (RH_Types)); if Present (Backend_Node (Identifier (E))) and then Present (CTN.Type_Definition_Node (Backend_Node (Identifier (E)))) then return Defining_Identifier (CTN.Type_Definition_Node (Backend_Node (Identifier (E)))); else return No_Node; end if; end Map_C_Data_Type_Designator; --------------------------------- -- Map_C_Subprogram_Identifier -- --------------------------------- function Map_C_Subprogram_Identifier (E : Node_Id) return Node_Id is P_Name : Name_Id; Result : Node_Id; 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_C then Display_Error ("This is not an C function", 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; -- Get the package implementation and add the 'with' clause P_Name := Unit_Name (Spg_Name); if P_Name = No_Name then Display_Error ("You must give the subprogram implementation name", Fatal => True); end if; -- Get the full implementation name Get_Name_String (Local_Name (Spg_Name)); Result := Make_Defining_Identifier (Name_Find); return Result; end Map_C_Subprogram_Identifier; ------------------------------- -- Map_C_Defining_Identifier -- ------------------------------- function Map_C_Defining_Identifier (A : Node_Id) return Node_Id is I : Node_Id; Result : Node_Id; begin if Kind (A) /= K_Identifier then I := Identifier (A); end if; Result := CTU.Make_Defining_Identifier (To_C_Name (Display_Name (I))); return Result; end Map_C_Defining_Identifier; ------------------------------ -- Map_C_Feature_Subprogram -- ------------------------------ function Map_C_Feature_Subprogram (A : Node_Id) return Node_Id is I : Node_Id; Result : Node_Id; M : Name_Id; N : Name_Id; begin if Kind (A) /= K_Identifier then I := Identifier (A); end if; M := CTU.To_C_Name (Display_Name (Identifier (Parent_Component (A)))); N := CTU.To_C_Name (Display_Name (I)); Get_Name_String (M); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (N); N := Name_Find; Result := CTU.Make_Defining_Identifier (N); return Result; end Map_C_Feature_Subprogram; --------------------------------- -- Map_C_Marshaller_Subprogram -- --------------------------------- function Map_C_Marshaller_Subprogram (A : Node_Id; Is_Unmarshall : Boolean := False; Is_Request : Boolean := False) return Node_Id is I : Node_Id; Result : Node_Id; N : Name_Id; Ada_Name : Name_Id; begin I := Identifier (A); if Kind (A) = K_Port_Spec_Instance then Ada_Name := CTU.To_C_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (A))))); end if; N := CTU.To_C_Name (Display_Name (I)); if Is_Request then if Is_Unmarshall then Set_Str_To_Name_Buffer ("__po_hi_unmarshall_request_"); else Set_Str_To_Name_Buffer ("__po_hi_marshall_request_"); end if; else if Is_Unmarshall then Set_Str_To_Name_Buffer ("__po_hi_unmarshall_type_"); else Set_Str_To_Name_Buffer ("__po_hi_marshall_type_"); end if; end if; if Kind (A) = K_Port_Spec_Instance then Get_Name_String_And_Append (Ada_Name); Add_Str_To_Name_Buffer ("_"); end if; Get_Name_String_And_Append (N); N := Name_Find; Result := CTU.Make_Defining_Identifier (N); return Result; end Map_C_Marshaller_Subprogram; ----------------------- -- Bind_AADL_To_Stub -- ----------------------- procedure Bind_AADL_To_Stub (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Stub_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Stub; ------------------------ -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Types_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Types; -------------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Default_Value_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Default_Value; ------------------------- -- 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 (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Object_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Object; ----------------------------- -- Bind_AADL_To_Marshaller -- ----------------------------- procedure Bind_AADL_To_Marshaller (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Marshaller_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Marshaller; ------------------------------- -- Bind_AADL_To_Unmarshaller -- ------------------------------- procedure Bind_AADL_To_Unmarshaller (G : Node_Id; A : Node_Id) is N : Node_Id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (CTN.K_HI_Tree_Bindings); AAN.Set_Backend_Node (G, N); end if; CTN.Set_Unmarshaller_Node (N, A); CTN.Set_Frontend_Node (A, G); end Bind_AADL_To_Unmarshaller; ------------------------- -- Map_Stub_Identifier -- ------------------------- function Map_Stub_Identifier (E : Node_Id) return Node_Id is begin Get_Name_String (To_C_Name (AAN.Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_stub"); return Make_Defining_Identifier (Name_Find); end Map_Stub_Identifier; --------------------------- -- Map_C_Subprogram_Spec -- --------------------------- function Map_C_Subprogram_Spec (S : Node_Id) return Node_Id is Profile : constant List_Id := CTU.New_List (CTN.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 := AAN.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 (AAN.Loc (F), "Unspecified parameter mode", Fatal => True); end if; D := Corresponding_Instance (F); if Mode = Mode_In then Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (F), Parameter_Type => Map_C_Data_Type_Designator (D)); else Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (F), Parameter_Type => CTU.Make_Pointer_Type (Map_C_Data_Type_Designator (D))); end if; CTU.Append_Node_To_List (Param, Profile); end if; F := AAN.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 := AAN.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 (AAN.Loc (F), "Unsupported required access", Fatal => True); end case; D := Corresponding_Instance (F); case Get_Data_Type (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. if Mode = Mode_In then Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (F), Parameter_Type => Map_C_Data_Type_Designator (D)); else Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (F), Parameter_Type => CTU.Make_Pointer_Type (Map_C_Data_Type_Designator (D))); end if; CTU.Append_Node_To_List (Param, Profile); when Data_Record | 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 := AAN.First_Node (Subcomponents (D)); while Present (Field) loop if Mode = Mode_In then Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (Field), Parameter_Type => Map_C_Data_Type_Designator (Corresponding_Instance (Field))); else Param := CTU.Make_Parameter_Specification (Defining_Identifier => Map_C_Defining_Identifier (Field), Parameter_Type => Make_Pointer_Type (Map_C_Data_Type_Designator (Corresponding_Instance (Field)))) ; end if; CTU.Append_Node_To_List (Param, Profile); Field := AAN.Next_Node (Field); end loop; when others => Display_Located_Error (AAN.Loc (F), "Unsupported data type", Fatal => True); end case; end if; F := AAN.Next_Node (F); end loop; end if; end if; N := CTU.Make_Function_Specification (Defining_Identifier => Map_C_Defining_Identifier (S), Parameters => Profile, Return_Type => New_Node (CTN.K_Void)); -- If the program is an Opaque_C, we add the Pragma Import -- instruction in the private par of the current package return N; end Map_C_Subprogram_Spec; --------------------------- -- Map_C_Subprogram_Body -- --------------------------- function Map_C_Subprogram_Body (S : Node_Id) return Node_Id is Spec : constant Node_Id := Map_C_Subprogram_Spec (S); User_Spec : constant Node_Id := Map_C_Subprogram_Spec (S); Declarations : constant List_Id := New_List (CTN.K_Declaration_List); Statements : constant List_Id := New_List (CTN.K_Statement_List); Call_Profile : constant List_Id := New_List (CTN.K_Parameter_Profile); N : Node_Id; P : Node_Id; begin Add_Include (RH (RH_Subprograms)); case Get_Subprogram_Kind (S) is when Subprogram_Empty => -- An empty AADL subprogram is mapped into an Ada -- subprogram that raises and exception to warn the user. N := Message_Comment ("Empty subprogram"); CTU.Append_Node_To_List (N, Statements); return Make_Function_Implementation (Spec, Declarations, Statements); when Subprogram_Opaque_C => if not Is_Empty (Parameters (Spec)) then P := CTN.First_Node (CTN.Parameters (Spec)); while Present (P) loop Append_Node_To_List (Copy_Node (Defining_Identifier (P)), Call_Profile); P := CTN.Next_Node (P); end loop; end if; -- Add the definition of the function provided by the user -- Don't use definition before use can cause some problems -- at the run-time. Set_Defining_Identifier (User_Spec, (Make_Defining_Identifier (Local_Name (Get_Source_Name (S))))); Append_Node_To_List (User_Spec, CTN.Declarations (Current_File)); -- Then, call the function provided by the user in our -- subprogram. N := Make_Call_Profile (Make_Defining_Identifier (Local_Name (Get_Source_Name (S))), Call_Profile); Append_Node_To_List (N, Statements); return CTU.Make_Function_Implementation (Spec, Declarations, Statements); when Subprogram_Opaque_Ada_95 => -- An opaque Ada AADL subprogram is a subprogram which is -- implemented by and Ada subprogram. We perform the -- mapping between the two subprogram using the Ada -- renaming facility. -- Add the proper `with' clause return No_Node; 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. CTU.Handle_Call_Sequence (S, AAN.First_Node (AAN.Calls (S)), Declarations, Statements); return CTU.Make_Function_Implementation (Spec, Declarations, Statements); when Subprogram_Hybrid_Ada_95 => return No_Node; when others => Display_Located_Error (AAN.Loc (S), "This kind of subprogram is not supported" & Get_Subprogram_Kind (S)'Img, Fatal => True); return No_Node; end case; end Map_C_Subprogram_Body; end Ocarina.Generators.PO_HI_C.Mapping;