------------------------------------- ------------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_QOS_ADA.SERVANTS -- -- -- -- 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; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components; with Ocarina.Generators.Utils; with Ocarina.Generators.Properties; with Ocarina.Generators.Messages; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.PO_QoS_Ada.Mapping; with Ocarina.Generators.PO_QoS_Ada.Runtime; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_QoS_Ada.Servants is use Namet; use Ocarina.Nodes; use Ocarina.Entities.Components; use Ocarina.Generators.Ada_Tree.Nutils; use Ocarina.Generators.Utils; use Ocarina.Generators.Properties; use Ocarina.Generators.Messages; use Ocarina.Generators.PO_QoS_Ada.Mapping; use Ocarina.Generators.PO_QoS_Ada.Runtime; use Ocarina.Generators.Ada_Values; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; ------------------ -- Package_Spec -- ------------------ package body Package_Spec is procedure Visit_Architecture_Instance (E : node_id); procedure Visit_Component_Instance (E : node_id); procedure Visit_System_Instance (E : node_id); procedure Visit_Process_Instance (E : node_id); procedure Visit_Thread_Instance (E : node_id); function Thread_Controller_Spec (E : node_id) return node_id; -- Makes a spec for the 'Thread_Name'_Controller subprogram function Object_Type_Declaration (T : node_id) return node_id; -- Makes the Object type declaration corresponding to a thread -- having IN ports function Reference_Declaration (E : node_id) return node_id; -- Makes the Reference declaration corresponding to a thread -- having IN ports or corresponding to a destination port function Execute_Servant_Spec (T : node_id) return node_id; -- Makes the spec of the Execute_Servant subprogram relative to -- an Object ----------- -- Visit -- ----------- procedure Visit (E : node_id) is begin case Kind (E) is when k_architecture_instance => Visit_Architecture_Instance (E); when k_component_instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : node_id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Visit_System_Instance (E); when cc_process => Visit_Process_Instance (E); when cc_thread => Visit_Thread_Instance (E); when others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is U : constant node_id := ADN.Distributed_Application_Unit (ADN.Helpers_Node (Backend_Node (Identifier (E)))); P : constant node_id := ADN.Entity (U); S : node_id; begin Push_Entity (P); Push_Entity (U); Set_Servants_Spec; -- Visit recursively all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin Push_Entity (QoS_Distributed_Application_Root); if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- QoS_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is N : node_id; F : node_id; D : node_id; begin Set_Servants_Spec; N := Message_Comment ("Thread: " & Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- The thread is mapped to a parameterless subprogram which -- controls its execution. N := Thread_Controller_Spec (E); Bind_AADL_To_Thread_Controller (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Handle the thread features if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_Out (F) then -- For each destination of the OUT Port, we -- generate a Reference to the destination. D := First_Node (Get_Destination_Ports (F)); while Present (D) loop N := Reference_Declaration (Item (D)); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); D := Next_Node (D); end loop; end if; F := Next_Node (F); end loop; end if; -- Create the protected object and the Servant routines when -- the thread has IN ports. if Has_In_Ports (E) then -- IMPORTANT: If the node contains more that 2 thread -- that have IN ports, the other nodes that send messages -- must know the index of the destination thread in the -- Ocarina Object Adapter static table. Compute_Servant_Index (E); N := Object_Type_Declaration (E); Bind_AADL_To_Type_Definition (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Reference_Declaration (E); Bind_AADL_To_Reference (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Execute_Servant_Spec (E); Bind_AADL_To_Execute_Servant (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end if; end Visit_Thread_Instance; ------------------------ -- Object_Declaration -- ------------------------ function Object_Type_Declaration (T : node_id) return node_id is O_Identifier : constant node_id := Map_Object_Type_Identifier (T); O_Type_Spec : constant node_id := RE (re_servant); N : node_id; begin N := Make_Full_Type_Declaration (Defining_Identifier => O_Identifier, Type_Definition => Make_Derived_Type_Definition (Subtype_Indication => O_Type_Spec, Record_Extension_Part => Make_Record_Definition (No_List))); return N; end Object_Type_Declaration; --------------------------- -- Reference_Declaration -- --------------------------- function Reference_Declaration (E : node_id) return node_id is R_Identifier : constant node_id := Map_Reference_Identifier (E); R_Type_Spec : constant node_id := RE (re_ref_3); N : node_id; begin N := Make_Object_Declaration (Defining_Identifier => R_Identifier, Object_Definition => R_Type_Spec); return N; end Reference_Declaration; -------------------------- -- Execute_Servant_Spec -- -------------------------- function Execute_Servant_Spec (T : node_id) return node_id is S_Identifier : constant node_id := Make_Defining_Identifier (SN (s_execute_servant)); O_Designator : constant node_id := Map_Object_Type_Identifier (T); N : node_id; Param_List : constant list_id := New_List (ADN.k_parameter_profile); begin -- First parameter N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_obj)), Subtype_Mark => Make_Access_Type_Definition (O_Designator, Is_Not_Null => True)); Append_Node_To_List (N, Param_List); -- Second Parameter N := Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (p_msg)), Subtype_Mark => Make_Attribute_Designator (RE (re_message), a_class)); Append_Node_To_List (N, Param_List); N := Make_Subprogram_Specification (Defining_Identifier => S_Identifier, Parameter_Profile => Param_List, Return_Type => Make_Attribute_Designator (RE (re_message), a_class)); return N; end Execute_Servant_Spec; ---------------------------- -- Thread_Controller_Spec -- ---------------------------- function Thread_Controller_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Map_Thread_Controller_Identifier (E), Parameter_Profile => No_List, Return_Type => No_Node); return N; end Thread_Controller_Spec; end Package_Spec; ------------------ -- Package_Body -- ------------------ package body Package_Body is procedure Visit_Architecture_Instance (E : node_id); procedure Visit_Component_Instance (E : node_id); procedure Visit_System_Instance (E : node_id); procedure Visit_Process_Instance (E : node_id); procedure Visit_Thread_Instance (E : node_id); procedure Visit_Data_Instance (E : node_id); Thread_Mutex : name_id; -- A reference on current thread's mutex name Initialize_Statements : list_id := No_List; -- The statements of the Initialize procedure function Thread_Controller_Body (E : node_id) return node_id; -- Makes a body for the 'Thread_Name'_Controller subprogram procedure Protected_Object_Routines_Specs (P : node_id); -- Creates the specs of the routines that handle the Buffer of -- the port P in the spec of the protected object. procedure Protected_Object_Routines_Bodies (P : node_id); -- Creates the bodies of the routines that handle the Buffer of -- the port P in the body of the protected object. function Get_Spec (P : node_id) return node_id; function Put_Spec (P : node_id) return node_id; function Push_Back_Spec (P : node_id) return node_id; -- Make the specs of the port buffer manipulating subprograms function Put_Body (P : node_id) return node_id; function Get_Body (P : node_id) return node_id; function Push_Back_Body (P : node_id) return node_id; -- Make the bodies of the port buffer manipulating subprograms function Execute_Servant_Body (T : node_id) return node_id; -- Makes the body of the Execute_Servant subprogram relative to -- an Object function Request_Handling (P : node_id; T : node_id) return node_id; -- Makes the request handling portion corresponding to the IN -- port P of the thread T function Buffer_Instance_Declaration (P : node_id) return node_id; -- Makes the buffer instance declaration for an event data port function Protected_Variable_Declaration (P : node_id) return node_id; -- Makes the variable declaration for a data port function Buffer_Package_Instantiation (P : node_id) return node_id; -- Make the package instantiation of a buffer corresponding to -- the FIFO of the IN port P. function Call_Subprogram (S : node_id; T : node_id; L : list_id) return node_id; -- Makes a call to subprogram_call S which belongs the a call -- sequence in the thread T. All necessary local variables are -- added to the given list. function Servant_Initialization return node_id; -- Initialization routines of the Servants package ----------- -- Visit -- ----------- procedure Visit (E : node_id) is begin case Kind (E) is when k_architecture_instance => Visit_Architecture_Instance (E); when k_component_instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : node_id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Visit_System_Instance (E); when cc_process => Visit_Process_Instance (E); when cc_thread => Visit_Thread_Instance (E); when cc_data => Visit_Data_Instance (E); when others => null; end case; end Visit_Component_Instance; ------------------------- -- Visit_Data_Instance -- ------------------------- procedure Visit_Data_Instance (E : node_id) is N : node_id; Data_Type : constant supported_data_type := Get_Data_Type (E); begin Set_Servants_Body; -- This is a shared variable -- Declare the global variable corresponding to the shared -- variable. N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (Parent_Subcomponent (E)), Object_Definition => Map_Ada_Data_Type_Designator (E)); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- If the shared variable is protected, add the routine that -- initializes it to the Initialize procedure statements. if (Data_Type = data_with_accessors or else Data_Type = data_record) and then Get_Concurrency_Protocol (E) = concurrency_protected_access then N := Make_Subprogram_Call (Extract_Designator (ADN.Build_Node (Backend_Node (Identifier (E)))), Make_List_Id (Map_Ada_Defining_Identifier (Parent_Subcomponent (E)))); Append_Node_To_List (N, Initialize_Statements); end if; end Visit_Data_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is U : constant node_id := ADN.Distributed_Application_Unit (ADN.Helpers_Node (Backend_Node (Identifier (E)))); P : constant node_id := ADN.Entity (U); N : node_id; S : node_id; begin Push_Entity (P); Push_Entity (U); Set_Servants_Body; -- Reset the Initialize_Statements list Initialize_Statements := New_List (ADN.k_statement_list); -- Visit all the data subcomponents of the process, since -- data have to be declared before their use. if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance if Utils.Is_Data (Corresponding_Instance (S)) then Visit (Corresponding_Instance (S)); end if; S := Next_Node (S); end loop; end if; -- Visit recursively all the threads if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance if Utils.Is_Thread (Corresponding_Instance (S)) then Visit (Corresponding_Instance (S)); end if; S := Next_Node (S); end loop; end if; -- Create the Initialize procedure when necessary if not Is_Empty (Initialize_Statements) then -- The spec N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (s_initialize)), No_List); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- The body N := Make_Subprogram_Implementation (N, No_List, Initialize_Statements); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Servants package initialization N := Servant_Initialization; ADN.Set_Package_Initialization (Current_Package, Make_List_Id (N)); end if; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin Push_Entity (QoS_Distributed_Application_Root); if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the corresponding component instance Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- QoS_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is N : node_id; F : node_id; Has_In_Ports : constant Boolean := Utils.Has_In_Ports (E); begin Set_Servants_Body; N := Message_Comment ("Thread: " & Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E))); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- If the thread has IN ports, begin by declaring a mutex if Has_In_Ports then N := Make_Object_Declaration (Defining_Identifier => Map_Mutex_Identifier (E), Object_Definition => RE (re_mutex_access)); Append_Node_To_List (N, ADN.Statements (Current_Package)); Thread_Mutex := ADN.Name (ADN.Defining_Identifier (N)); -- Append mutex initialization to the Initialize -- procedure statements. N := Make_Subprogram_Call (RE (re_create_2), Make_List_Id (Map_Mutex_Identifier (E))); Append_Node_To_List (N, Initialize_Statements); end if; -- Handle the thread features if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) then -- For each IN port, we declare: if Is_Event (F) then -- 1) A buffer package that plays the role of -- the port FIFO (EVENT ports only). N := Buffer_Package_Instantiation (F); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Link the feature to the table type Bind_AADL_To_Package (Identifier (F), Make_Selected_Component (Map_Package_Identifier (F), Make_Defining_Identifier (TN (t_table)))); end if; -- 2) Routines of the protected object that handles -- the port buffer. Protected_Object_Routines_Specs (F); Protected_Object_Routines_Bodies (F); end if; F := Next_Node (F); end loop; end if; -- The body of the thread controller subprogram N := Thread_Controller_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- If the thread has IN ports, end by generating the body of -- the Execute_Servant procedure. if Has_In_Ports then N := Execute_Servant_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; end Visit_Thread_Instance; ---------------------------- -- Thread_Controller_Body -- ---------------------------- function Thread_Controller_Body (E : node_id) return node_id is Spec : constant node_id := ADN.Thread_Controller_Node (Backend_Node (Identifier (E))); Declarative_Part : constant list_id := New_List (ADN.k_declaration_list); Statements : list_id := New_List (ADN.k_statement_list); If_Condition : node_id := RE (re_true); Then_Statements : constant list_id := New_List (ADN.k_statement_list); Else_Statements : constant list_id := New_List (ADN.k_statement_list); Has_In_ED_Ports : Boolean := False; N : node_id; F : node_id; C : node_id; S : node_id; P : node_id; SD : node_id; D : node_id; Aggregate : node_id; begin -- Read the shared variables if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_subcomponent_access_instance then -- The access to the subcomponent has to be REQUIRED if Is_Provided (F) then Display_Located_Error (Loc (F), "Thread providing access to a data not supported", Fatal => True); end if; -- Get the source subcomponent of the data access SD := Get_Subcomponent_Access_Source (F); D := Corresponding_Instance (SD); if Get_Data_Type (D) = data_with_accessors or else Get_Data_Type (D) = data_record then Aggregate := First_Node (Subcomponents (D)); while Present (Aggregate) loop -- Declare the local variable N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Protected_Aggregate_Identifier (F, Aggregate), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (Aggregate))); Append_Node_To_List (N, Declarative_Part); -- Get the field value if Get_Concurrency_Protocol (D) = concurrency_protected_access then -- For protected data with synchronous -- update policy, we read the value of -- each field. N := Make_Subprogram_Call (Extract_Designator (ADN.Get_Node (Backend_Node (Identifier (Aggregate)))), Make_List_Id (Map_Ada_Defining_Identifier (SD), Map_Ada_Protected_Aggregate_Identifier (F, Aggregate))); Append_Node_To_List (N, Statements); else -- Non-protected shared object we simply -- perform an assignment. N := Make_Assignment_Statement (Map_Ada_Protected_Aggregate_Identifier (F, Aggregate), Make_Selected_Component (Map_Ada_Defining_Identifier (SD), Map_Ada_Defining_Identifier (Aggregate))); Append_Node_To_List (N, Statements); end if; Aggregate := Next_Node (Aggregate); end loop; end if; end if; F := Next_Node (F); end loop; end if; -- Handling the thread ports if not AAU.Is_Empty (Features (E)) then P := First_Node (Features (E)); while Present (P) loop if Kind (P) = k_port_spec_instance then -- Whatever the kind, declare a loacal variable -- having the port type. N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (P), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (P))); Append_Node_To_List (N, Declarative_Part); -- IN ports if Is_In (P) then -- Handle data coherence in case of event data -- ports. if Is_Event (P) then Has_In_ED_Ports := True; -- The boolean flag corresponding to the port N := Make_Object_Declaration (Defining_Identifier => Map_Port_Boolean_Identifier (P), Object_Definition => RE (re_boolean_2)); Append_Node_To_List (N, Declarative_Part); -- Get the port value from the corresponding -- port buffer. N := Extract_Designator (ADN.Get_Node (Backend_Node (Identifier (P)))); N := Make_Subprogram_Call (N, Make_List_Id (Map_Ada_Defining_Identifier (P), Map_Port_Boolean_Identifier (P))); Append_Node_To_List (N, Statements); -- Update the IF statement condition If_Condition := Make_Expression (If_Condition, op_and_then, Map_Port_Boolean_Identifier (P)); -- Update the ELSE statement N := Extract_Designator (ADN.Push_Back_Node (Backend_Node (Identifier (P)))); N := Make_Subprogram_Call (N, Make_List_Id (Map_Ada_Defining_Identifier (P))); N := Make_If_Statement (Condition => Map_Port_Boolean_Identifier (P), Then_Statements => Make_List_Id (N)); Append_Node_To_List (N, Else_Statements); else -- Get the port value from the corresponding -- port buffer. N := Extract_Designator (ADN.Get_Node (Backend_Node (Identifier (P)))); N := Make_Subprogram_Call (N, Make_List_Id (Map_Ada_Defining_Identifier (P))); Append_Node_To_List (N, Statements); end if; end if; end if; P := Next_Node (P); end loop; end if; -- Call the subprograms in the thread call sequences if not AAU.Is_Empty (Calls (E)) then Check_Thread_Consistency (E); C := First_Node (Calls (E)); if not AAU.Is_Empty (Subprogram_Calls (C)) then S := First_Node (Subprogram_Calls (C)); while Present (S) loop N := Call_Subprogram (S, E, Declarative_Part); Append_Node_To_List (N, Then_Statements); S := Next_Node (S); end loop; end if; end if; -- Handling the thread OUT ports if not AAU.Is_Empty (Features (E)) then P := First_Node (Features (E)); while Present (P) loop if Kind (P) = k_port_spec_instance then -- OUT ports if Is_Out (P) then -- For each destination of the port, emit a message D := First_Node (Get_Destination_Ports (P)); while Present (D) loop -- Get the designator of the To_Any function -- corresponding to the type_spec of port P N := Extract_Designator (ADN.To_Any_Node (Backend_Node (Identifier (Corresponding_Instance (P))))); N := Make_Subprogram_Call (N, Make_List_Id (Map_Ada_Defining_Identifier (P))); N := Make_Subprogram_Call (RE (re_emit_msg), Make_List_Id (N, Map_Reference_Identifier (Item (D)), Make_Literal (New_String_Value (Name (Identifier (Item (D))))))); Append_Node_To_List (N, Then_Statements); D := Next_Node (D); end loop; end if; end if; P := Next_Node (P); end loop; end if; -- If the thread contains IN event data ports, we build an -- IF statement that controls the data polling from port -- buffers if Has_In_ED_Ports then N := Make_If_Statement (Condition => If_Condition, Then_Statements => Then_Statements, Else_Statements => Else_Statements); Append_Node_To_List (N, Statements); else Append_Node_To_List (ADN.First_Node (Then_Statements), Statements); end if; -- If the thread is periodic we put all the statements in a -- loop if Get_Thread_Dispatch_Protocol (E) = thread_periodic then -- Extra declarations N := Make_Used_Type (RE (re_time)); Append_Node_To_List (N, Declarative_Part); N := Make_Used_Type (RE (re_time_span)); Append_Node_To_List (N, Declarative_Part); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_next_start)), Object_Definition => RE (re_time), Expression => Make_Subprogram_Call (RE (re_clock))); Append_Node_To_List (N, Declarative_Part); -- Get the thread period N := Map_Ada_Time (Get_Thread_Period (E)); if No (N) then Display_Located_Error (Loc (E), "Unable to convert picoseconds period into nanoseconds", Fatal => True); end if; N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_period)), Constant_Present => True, Object_Definition => RE (re_time_span), Expression => N); Append_Node_To_List (N, Declarative_Part); -- Add the delay for the next period N := Make_Expression (Make_Defining_Identifier (PN (p_next_start)), op_plus, Make_Defining_Identifier (PN (p_period))); N := Make_Assignment_Statement (Make_Defining_Identifier (PN (p_next_start)), N); Append_Node_To_List (N, Statements); N := Make_Delay_Statement (Expression => Make_Defining_Identifier (PN (p_next_start)), Is_Until => True); Append_Node_To_List (N, Statements); -- Make the global loop statement N := Make_Loop_Statement (Statements); Statements := Make_List_Id (N); end if; -- Write back the shared variables if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_subcomponent_access_instance then -- The access to the subcomponent has to be REQUIRED if Is_Provided (F) then Display_Located_Error (Loc (F), "Thread providing access to a data not supported", Fatal => True); end if; -- Get the source subcomponent of the data access SD := Get_Subcomponent_Access_Source (F); D := Corresponding_Instance (SD); if Get_Data_Type (D) = data_with_accessors or else Get_Data_Type (D) = data_record then -- For protected data with synchronous update -- policy, we read the value of each field. Aggregate := First_Node (Subcomponents (D)); while Present (Aggregate) loop if Get_Concurrency_Protocol (D) = concurrency_protected_access then N := Make_Subprogram_Call (Extract_Designator (ADN.Set_Node (Backend_Node (Identifier (Aggregate)))), Make_List_Id (Map_Ada_Defining_Identifier (SD), Map_Ada_Protected_Aggregate_Identifier (F, Aggregate))); Append_Node_To_List (N, Statements); else N := Make_Assignment_Statement (Make_Selected_Component (Map_Ada_Defining_Identifier (SD), Map_Ada_Defining_Identifier (Aggregate)), Map_Ada_Protected_Aggregate_Identifier (F, Aggregate)); Append_Node_To_List (N, Statements); end if; Aggregate := Next_Node (Aggregate); end loop; end if; end if; F := Next_Node (F); end loop; end if; -- Build the subprogram body N := Make_Subprogram_Implementation (Spec, Declarative_Part, Statements); return N; end Thread_Controller_Body; ------------------------------------ -- Protected_Object_Routines_Body -- ------------------------------------ procedure Protected_Object_Routines_Bodies (P : node_id) is N : node_id; begin -- 1) Put_ N := Put_Body (P); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 2) Get_ N := Get_Body (P); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 3) Push_Back_ if Is_Event (P) then N := Push_Back_Body (P); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; end Protected_Object_Routines_Bodies; -------------- -- Put_Body -- -------------- function Put_Body (P : node_id) return node_id is Spec : constant node_id := ADN.Put_Node (Backend_Node (Identifier (P))); Statements : constant list_id := New_List (ADN.k_statement_list); Dcl_Part : constant list_id := New_List (ADN.k_declaration_list); F : node_id; N : node_id; begin N := Make_Subprogram_Call (RE (re_enter), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); if Is_Event (P) then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_error)), Object_Definition => RE (re_boolean_1)); Append_Node_To_List (N, Dcl_Part); F := Make_Selected_Component (Map_Package_Identifier (P), RE (re_append)); N := Make_Subprogram_Call (F, Make_List_Id (Map_Buffer_Instance_Identifier (P), Map_Ada_Defining_Identifier (P), Make_Defining_Identifier (PN (p_error)))); Append_Node_To_List (N, Statements); else N := Make_Assignment_Statement (Variable_Identifier => Map_Variable_Identifier (P), Expression => Map_Ada_Defining_Identifier (P)); Append_Node_To_List (N, Statements); end if; N := Make_Subprogram_Call (RE (re_leave), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Dcl_Part, Statements); return N; end Put_Body; -------------------- -- Push_Back_Body -- -------------------- function Push_Back_Body (P : node_id) return node_id is Spec : constant node_id := ADN.Push_Back_Node (Backend_Node (Identifier (P))); Statements : constant list_id := New_List (ADN.k_statement_list); Dcl_Part : constant list_id := New_List (ADN.k_declaration_list); F : node_id; N : node_id; begin N := Make_Subprogram_Call (RE (re_enter), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_error)), Object_Definition => RE (re_boolean_1)); Append_Node_To_List (N, Dcl_Part); F := Make_Selected_Component (Map_Package_Identifier (P), RE (re_push_back)); N := Make_Subprogram_Call (F, Make_List_Id (Map_Buffer_Instance_Identifier (P), Map_Ada_Defining_Identifier (P), Make_Defining_Identifier (PN (p_error)))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Call (RE (re_leave), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Dcl_Part, Statements); return N; end Push_Back_Body; -------------- -- Get_Body -- -------------- function Get_Body (P : node_id) return node_id is Spec : constant node_id := ADN.Get_Node (Backend_Node (Identifier (P))); Statements : constant list_id := New_List (ADN.k_statement_list); Dcl_Part : constant list_id := New_List (ADN.k_declaration_list); F : node_id; N : node_id; begin N := Make_Subprogram_Call (RE (re_enter), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); if Is_Event (P) then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_error)), Object_Definition => RE (re_boolean_1)); Append_Node_To_List (N, Dcl_Part); F := Make_Selected_Component (Map_Package_Identifier (P), RE (re_get)); N := Make_Subprogram_Call (F, Make_List_Id (Map_Buffer_Instance_Identifier (P), Map_Ada_Defining_Identifier (P), Make_Defining_Identifier (PN (p_error)))); Append_Node_To_List (N, Statements); N := Make_Expression (Make_Defining_Identifier (PN (p_error)), op_not); N := Make_Assignment_Statement (Map_Port_Boolean_Identifier (P), N); Append_Node_To_List (N, Statements); else N := Make_Assignment_Statement (Variable_Identifier => Map_Ada_Defining_Identifier (P), Expression => Map_Variable_Identifier (P)); Append_Node_To_List (N, Statements); end if; N := Make_Subprogram_Call (RE (re_leave), Make_List_Id (Make_Defining_Identifier (Thread_Mutex))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Dcl_Part, Statements); return N; end Get_Body; -------------------------- -- Execute_Servant_Body -- -------------------------- function Execute_Servant_Body (T : node_id) return node_id is Spec : constant node_id := ADN.Execute_Servant_Node (Backend_Node (Identifier (T))); Declarative_Part : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); If_Condition : node_id; Then_Statements : constant list_id := New_List (ADN.k_statement_list); Else_Statements : constant list_id := New_List (ADN.k_statement_list); Block_Dcl : constant list_id := New_List (ADN.k_declaration_list); Block_Statements : constant list_id := New_List (ADN.k_statement_list); N : node_id; P : node_id; begin -- Adding a pragma unrefernced for tha Obj parameter N := Make_Pragma_Statement (pragma_unreferenced, Make_List_Id (Make_Defining_Identifier (PN (p_obj)))); Append_Node_To_List (N, Declarative_Part); -- Build the global block -- Fill the block's declarative part N := Make_Subprogram_Call (RE (re_execute_request), Make_List_Id (Make_Defining_Identifier (PN (p_msg)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_e_req)), Object_Definition => RE (re_execute_request), Renamed_Object => N); Append_Node_To_List (N, Block_Dcl); N := Make_Selected_Component (Make_Defining_Identifier (PN (p_e_req)), Make_Defining_Identifier (PN (p_req))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_req)), Object_Definition => RE (re_request_access), Renamed_Object => N); Append_Node_To_List (N, Block_Dcl); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_arg_list)), Object_Definition => RE (re_ref_2)); Append_Node_To_List (N, Block_Dcl); -- Handle each one of the IN ports if not AAU.Is_Empty (Features (T)) then P := First_Node (Features (T)); while Present (P) loop if Kind (P) = k_port_spec_instance and then Is_In (P) then N := Request_Handling (P, T); Append_Node_To_List (N, Block_Statements); end if; P := Next_Node (P); end loop; end if; -- The return statement N := Make_Component_Association (Make_Defining_Identifier (PN (p_req)), Make_Defining_Identifier (PN (p_req))); N := Make_Record_Aggregate (Make_List_Id (N)); N := Make_Qualified_Expression (RE (re_executed_request), Aggregate => N); N := Make_Return_Statement (N); Append_Node_To_List (N, Block_Statements); N := Make_Block_Statement (Declarative_Part => Block_Dcl, Statements => Block_Statements); Append_Node_To_List (N, Then_Statements); -- Build the global IF statement If_Condition := Make_Expression (Make_Defining_Identifier (PN (p_msg)), op_in, RE (re_execute_request)); N := Make_Raise_Statement (Make_Defining_Identifier (EN (e_program_error))); Append_Node_To_List (N, Else_Statements); N := Make_If_Statement (Condition => If_Condition, Then_Statements => Then_Statements, Else_Statements => Else_Statements); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarative_Part, Statements); return N; end Execute_Servant_Body; ---------------------- -- Request_Handling -- ---------------------- function Request_Handling (P : node_id; T : node_id) return node_id is If_Condition : node_id; Then_Statements : constant list_id := New_List (ADN.k_statement_list); Block_Dcl : constant list_id := New_List (ADN.k_declaration_list); Block_Statements : constant list_id := New_List (ADN.k_statement_list); N : node_id; Profile : constant list_id := New_List (ADN.k_list_id); begin -- Declarative part of the external record -- Get the TypeCode varable corresponding to the type_spec -- of port P N := Extract_Designator (ADN.TypeCode_Node (Backend_Node (Identifier (Corresponding_Instance (P))))); N := Make_Subprogram_Call (RE (re_to_ref), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_get_empty_any), Make_List_Id (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_argument)), Object_Definition => RE (re_any), Constant_Present => True, Expression => N); Append_Node_To_List (N, Block_Dcl); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_error)), Object_Definition => RE (re_error_container)); Append_Node_To_List (N, Block_Dcl); -- Statements of the external record... -- ...Create the NVList N := Make_Subprogram_Call (RE (re_create), Make_List_Id (Make_Defining_Identifier (PN (p_arg_list)))); Append_Node_To_List (N, Block_Statements); -- ...Add the port to the NVList N := Make_Defining_Identifier (PN (p_arg_list)); Append_Node_To_List (N, Profile); N := Make_Subprogram_Call (RE (re_to_polyorb_string), Make_List_Id (Make_Literal (New_String_Value (Name (Identifier (P)))))); Append_Node_To_List (N, Profile); N := Make_Defining_Identifier (PN (p_argument)); Append_Node_To_List (N, Profile); N := RE (re_arg_in); Append_Node_To_List (N, Profile); N := Make_Subprogram_Call (RE (re_add_item), Profile); Append_Node_To_List (N, Block_Statements); -- ...Call the Arguments procedure N := Make_Subprogram_Call (RE (re_arguments), Make_List_Id (Make_Defining_Identifier (PN (p_req)), Make_Defining_Identifier (PN (p_arg_list)), Make_Defining_Identifier (PN (p_error)))); Append_Node_To_List (N, Block_Statements); -- ...Inner block statement declare Inner_Dcl : constant list_id := New_List (ADN.k_declaration_list); Inner_Statements : constant list_id := New_List (ADN.k_statement_list); begin N := Extract_Designator (ADN.From_Any_Node (Backend_Node (Identifier (Corresponding_Instance (P))))); N := Make_Subprogram_Call (N, Make_List_Id (Make_Defining_Identifier (PN (p_argument)))); N := Make_Object_Declaration (Defining_Identifier => Map_Port_Argument_Identifier (P), Constant_Present => True, Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (P)), Expression => N); Append_Node_To_List (N, Inner_Dcl); -- Put the new received value N := Extract_Designator (ADN.Put_Node (Backend_Node (Identifier (P)))); N := Make_Subprogram_Call (N, Make_List_Id (Map_Port_Argument_Identifier (P))); Append_Node_To_List (N, Inner_Statements); -- If the port is an event data port, call the thread -- controller if Is_Event (P) then N := Extract_Designator (ADN.Thread_Controller_Node (Backend_Node (Identifier (T)))); N := Make_Subprogram_Call (N, No_List); Append_Node_To_List (N, Inner_Statements); end if; N := Make_Block_Statement (Declarative_Part => Inner_Dcl, Statements => Inner_Statements); Append_Node_To_List (N, Block_Statements); end; -- Make the external block statement N := Make_Block_Statement (Declarative_Part => Block_Dcl, Statements => Block_Statements); Append_Node_To_List (N, Then_Statements); -- Make the IF statement N := Make_Designator (PN (p_operation), PN (p_req), True); If_Condition := Make_Expression (N, op_equal, Make_Literal (New_String_Value (Name (Identifier (P))))); N := Make_If_Statement (Condition => If_Condition, Then_Statements => Then_Statements); return N; end Request_Handling; ------------------------------------- -- Protected_Object_Routines_Specs -- ------------------------------------- procedure Protected_Object_Routines_Specs (P : node_id) is N : node_id; begin -- Visible Part: for each IN event data port, we declare: -- 1) A Put_ procedure that puts its argument in -- the Port buffer N := Put_Spec (P); Bind_AADL_To_Put (Identifier (P), N); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 2) A Get_ procedure that puts its argument in -- the Port buffer N := Get_Spec (P); Bind_AADL_To_Get (Identifier (P), N); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 3) A Push_Back_ procedure that puts its argument in -- the Port buffer when the user wants it. This is needed -- only for event data ports. if Is_Event (P) then N := Push_Back_Spec (P); Bind_AADL_To_Push_Back (Identifier (P), N); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; -- Private Part: for each port, we declare a buffer instance -- if we deal with an event data port and a simple variable -- if we deal with a data port if Is_Event (P) then N := Buffer_Instance_Declaration (P); else N := Protected_Variable_Declaration (P); end if; Append_Node_To_List (N, ADN.Statements (Current_Package)); end Protected_Object_Routines_Specs; ---------------------------------- -- Buffer_Package_Instantiation -- ---------------------------------- function Buffer_Package_Instantiation (P : node_id) return node_id is B_Identifier : constant node_id := Map_Package_Identifier (P); B_Type_Spec : constant node_id := Map_Ada_Data_Type_Designator (Corresponding_Instance (P)); Queue_Size : constant long_long := Get_Queue_Size (P); B_Size : value_id; N : node_id; begin if Queue_Size = -1 then -- Allocate a default size B_Size := New_Integer_Value (default_queue_size, 1, 10); elsif Queue_Size = 0 then -- 0 length queues are not supported Display_Located_Error (Loc (P), "Zero length port queues are not supported", Fatal => True); else B_Size := New_Integer_Value (unsigned_long_long (Queue_Size), 1, 10); end if; N := Make_Package_Instantiation (B_Identifier, RU (ru_arao_cyclic_array), Make_List_Id (B_Type_Spec, Make_Literal (B_Size))); return N; end Buffer_Package_Instantiation; --------------------------------- -- Buffer_Instance_Declaration -- --------------------------------- function Buffer_Instance_Declaration (P : node_id) return node_id is V_Identifier : constant node_id := Map_Buffer_Instance_Identifier (P); B_Identifier : constant node_id := ADN.Package_Node (Backend_Node (Identifier (P))); N : node_id; begin N := Make_Object_Declaration (Defining_Identifier => V_Identifier, Object_Definition => B_Identifier); return N; end Buffer_Instance_Declaration; ------------------------------------ -- Protected_Variable_Declaration -- ------------------------------------ function Protected_Variable_Declaration (P : node_id) return node_id is V_Identifier : constant node_id := Map_Variable_Identifier (P); V_Type_Spec : constant node_id := Map_Ada_Data_Type_Designator (Corresponding_Instance (P)); N : node_id; begin N := Make_Object_Declaration (Defining_Identifier => V_Identifier, Object_Definition => V_Type_Spec); return N; end Protected_Variable_Declaration; -------------- -- Put_Spec -- -------------- function Put_Spec (P : node_id) return node_id is S_Identifier : constant node_id := Map_Put_Subprogram_Identifier (P); P_Identifier : constant node_id := Map_Ada_Defining_Identifier (P); N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => S_Identifier, Parameter_Profile => Make_List_Id (Make_Parameter_Specification (P_Identifier, Map_Ada_Data_Type_Designator (Corresponding_Instance (P)))), Return_Type => No_Node); ADN.Set_Parent (N, No_Node); return N; end Put_Spec; -------------------- -- Push_Back_Spec -- -------------------- function Push_Back_Spec (P : node_id) return node_id is S_Identifier : constant node_id := Map_Push_Back_Subprogram_Identifier (P); P_Identifier : constant node_id := Map_Ada_Defining_Identifier (P); N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => S_Identifier, Parameter_Profile => Make_List_Id (Make_Parameter_Specification (P_Identifier, Map_Ada_Data_Type_Designator (Corresponding_Instance (P)))), Return_Type => No_Node); ADN.Set_Parent (N, No_Node); return N; end Push_Back_Spec; -------------- -- Get_Spec -- -------------- function Get_Spec (P : node_id) return node_id is S_Identifier : constant node_id := Map_Get_Subprogram_Identifier (P); P_Identifier : constant node_id := Map_Ada_Defining_Identifier (P); B_Identifier : constant node_id := Map_Port_Boolean_Identifier (P); Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin N := Make_Parameter_Specification (P_Identifier, Map_Ada_Data_Type_Designator (Corresponding_Instance (P)), mode_out); Append_Node_To_List (N, Profile); -- If the port is an event data port add a boolean flag if Is_Event (P) then N := Make_Parameter_Specification (B_Identifier, RE (re_boolean_2), mode_out); Append_Node_To_List (N, Profile); end if; N := Make_Subprogram_Specification (Defining_Identifier => S_Identifier, Parameter_Profile => Profile, Return_Type => No_Node); ADN.Set_Parent (N, No_Node); return N; end Get_Spec; --------------------- -- Call_Subprogram -- --------------------- function Call_Subprogram (S : node_id; T : node_id; L : list_id) return node_id is N : node_id; Call_Profile : constant list_id := New_List (ADN.k_list_id); Spg : constant node_id := Corresponding_Instance (S); F : node_id; D : node_id; Field : node_id; Destination_F : node_id; Source_F : node_id; Param_Value : node_id; Source_Parent : node_id; begin 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 IN 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 2 possible -- values (see the (1) and (2) comments below). if Parent_Component (Destination_F) /= T then -- Here, we map the variable name from the -- subprogram *call* name and the feature -- name. This avoids name clashing when a thread -- calls twice the same subprogram. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Ada_Full_Parameter_Name (S, F)), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); Append_Node_To_List (N, L); -- (1) If we declared a local variable, we use it -- as parameter value. Param_Value := Make_Designator (Map_Ada_Full_Parameter_Name (S, F)); else -- (2) If the S parameter is connected to -- a T port, then we use simply the -- corresponding paremeter of S. Param_Value := Make_Designator (To_Ada_Name (Display_Name (Identifier (Destination_F)))); end if; -- For each OUT parameter we build a parameter -- association of the actual profile of the -- implmentaion subprogram call => -- . N := Make_Parameter_Association (Selector_Name => Map_Ada_Defining_Identifier (F), Actual_Parameter => Param_Value); 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", 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) above). if Is_Thread (Source_Parent) then -- (1) If the Parent of 'Source_F' is a thread, -- then we use the temporary declared variable -- corresponding to the thread port Param_Value := Map_Ada_Defining_Identifier (Source_F); else -- (2) If the the source parent is another -- subprogram call we use the previously -- declared variable. Param_Value := Make_Designator (Map_Ada_Full_Parameter_Name (Parent_Subcomponent (Source_Parent), Source_F)); end if; -- For each IN parameter we build a parameter -- association association of the actual profile of -- the implmentaion subprogram call => -- . N := Make_Parameter_Association (Selector_Name => Map_Ada_Defining_Identifier (F), Actual_Parameter => Param_Value); Append_Node_To_List (N, Call_Profile); end if; F := Next_Node (F); end loop; end if; -- 2 - The list of all record fileds given -- FIXME: Respect the mapping rules by setting the correct -- parameter orientation. For now all parameter are -- considered IN OUT. Provide all necessary routines -- (passing through intermediate variables, to prevent the -- user from cheating). 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 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 association mpped from the -- data component. N := Make_Parameter_Association (Selector_Name => Map_Ada_Defining_Identifier (F), Actual_Parameter => Map_Ada_Defining_Identifier (D)); Append_Node_To_List (N, Call_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 := First_Node (Subcomponents (D)); while Present (Field) loop N := Make_Parameter_Association (Selector_Name => Map_Ada_Protected_Aggregate_Identifier (F, Field), Actual_Parameter => Map_Ada_Protected_Aggregate_Identifier (F, Field)); Append_Node_To_List (N, Call_Profile); 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; N := Make_Subprogram_Call (Extract_Designator (ADN.Subprogram_Node (Backend_Node (Identifier (Spg)))), Call_Profile); return N; end Call_Subprogram; ---------------------------- -- Servant_Initialization -- ---------------------------- function Servant_Initialization return node_id is N : node_id; V : value_id; Aggregates : constant list_id := New_List (ADN.k_component_list); Declarative_Part : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); begin -- Declarative part -- Adding 'use' clauses to make the code more readable N := Make_Used_Package (RU (ru_polyorb_utils_strings)); Append_Node_To_List (N, Declarative_Part); N := Make_Used_Package (RU (ru_polyorb_utils_strings_lists)); Append_Node_To_List (N, Declarative_Part); -- Statements -- The package name N := ADN.Defining_Identifier (ADN.Package_Declaration (Current_Package)); V := New_String_Value (Fully_Qualified_Name (N)); N := Make_Expression (Make_Literal (V), op_plus); N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_name)), Expression => N); Append_Node_To_List (N, Aggregates); -- The conflicts N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_conflicts)), Expression => RE (re_empty)); Append_Node_To_List (N, Aggregates); -- Building the dependancy list of the package N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_depends)), Expression => Make_Expression (Map_Dependency (RU (ru_polyorb_any_initialization, False)), op_plus)); Append_Node_To_List (N, Aggregates); -- Provides N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_provides)), Expression => RE (re_empty)); Append_Node_To_List (N, Aggregates); -- Implicit N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_implicit)), Expression => RE (re_false)); Append_Node_To_List (N, Aggregates); -- Init procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_init)), Expression => Make_Type_Attribute (Make_Designator (SN (s_initialize)), a_access)); Append_Node_To_List (N, Aggregates); -- Shutdown procedure N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_shutdown)), Expression => Make_Null_Statement); Append_Node_To_List (N, Aggregates); -- Registering the module N := Make_Record_Aggregate (Aggregates); N := Make_Qualified_Expression (Subtype_Mark => RE (re_module_info), Aggregate => N); N := Make_Subprogram_Call (RE (re_register_module), Make_List_Id (N)); Append_Node_To_List (N, Statements); -- Building the initialization block statement N := Make_Block_Statement (Declarative_Part => Declarative_Part, Statements => Statements); return N; end Servant_Initialization; end Package_Body; end Ocarina.Generators.PO_QoS_Ada.Servants;