-------------------------------- ------------------------------------------------ -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_QOS_ADA.PARAMETERS -- -- -- -- 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.Runtime; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_QoS_Ada.Parameters is use Namet; use Ocarina.Nodes; use Ocarina.Entities.Components; use Ocarina.Generators.Utils; use Ocarina.Generators.Properties; use Ocarina.Generators.Messages; use Ocarina.Generators.Ada_Tree.Nutils; 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); ----------- -- 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 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); N : node_id; begin Push_Entity (P); Push_Entity (U); -- We only set parameters for processes that have IN -- ports. Processes that have only OUT port does not have -- port number. if not Has_In_Ports (E) then return; end if; Set_Parameters_Spec; -- Elaborate the body of the package N := Make_Pragma_Statement (pragma_elaborate_body, No_List); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); 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; 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); function Parameter_Entry_Type return node_id; -- Declare a new record for parameter entry function Array_Type return node_id; -- Declare an 2D-array type of Parameter_Entry function Array_Initialization (E : node_id) return node_id; -- Build the array static initialization function Partition_Source_Type return node_id; -- The Partition_Source type declaration function Partition_Source_Variable return node_id; -- Declare a variable of type Partition_Source function Get_Conf_Spec return node_id; -- Spec of the Get_Conf subprogram function Get_Conf_Body return node_id; -- Body of the Get_Conf subprogram function Initialize_Spec return node_id; -- Spec of the Initialize procedure function Initialize_Body return node_id; -- Body of the Initialize procedure function Parameters_Initialization return node_id; -- Initilization block of the Parameters package Current_Distributed_Application : node_id; ----------- -- 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 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); N : node_id; begin Push_Entity (P); Push_Entity (U); -- We only set parameters for processes that have IN -- ports. Processes that have only OUT port does not have -- port number. if not Has_In_Ports (E) then return; end if; Set_Parameters_Body; -- The Parameter_Entry record type declaration N := Parameter_Entry_Type; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- The Conf_Table static stable declaration N := Make_Defining_Identifier (CN (c_conf_table)); N := Make_Object_Declaration (Defining_Identifier => N, Constant_Present => True, Object_Definition => Array_Type, Expression => Array_Initialization (E)); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- The Partition_Source type declaration N := Partition_Source_Type; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Spec of the overriding function Get_Conf. It should -- appear immediately after the type. N := Get_Conf_Spec; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- The The_Partition_Source global variable declaratin N := Partition_Source_Variable; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Spec for the Initialize function of the Parameters -- package. N := Initialize_Spec; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Bodies of the package subprograms N := Get_Conf_Body; Append_Node_To_List (N, ADN.Statements (Current_Package)); N := Initialize_Body; Append_Node_To_List (N, ADN.Statements (Current_Package)); ADN.Set_Package_Initialization (Current_Package, Make_List_Id (Parameters_Initialization)); 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 Current_Distributed_Application := E; 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; -------------------------- -- Parameter_Entry_Type -- -------------------------- function Parameter_Entry_Type return node_id is N : node_id; C_List : constant list_id := New_List (ADN.k_component_list); begin N := Make_Component_Declaration (Make_Defining_Identifier (PN (p_key)), RE (re_string_ptr)); Append_Node_To_List (N, C_List); N := Make_Component_Declaration (Make_Defining_Identifier (PN (p_value)), RE (re_string_ptr)); Append_Node_To_List (N, C_List); N := Make_Record_Type_Definition (Make_Record_Definition (C_List)); N := Make_Full_Type_Declaration (Make_Defining_Identifier (TN (t_parameter_entry)), N); return N; end Parameter_Entry_Type; ---------------- -- Array_Type -- ---------------- function Array_Type return node_id is N : node_id; begin N := Make_Range_Constraint (Make_Literal (New_Integer_Value (1, 1, 10)), Make_Literal (New_Integer_Value (2, 1, 10))); N := Make_Array_Type_Definition (Make_List_Id (N), Make_Defining_Identifier (TN (t_parameter_entry))); return N; end Array_Type; -------------------------- -- Array_Initialization -- -------------------------- function Array_Initialization (E : node_id) return node_id is L : constant list_id := New_List (ADN.k_list_id); Protocol : constant protocol_type := Get_Protocol (Current_Distributed_Application); Location : constant name_id := Get_Processor_Location (Get_Bound_Processor (E)); Port_Number : constant value_id := Get_Process_Port_Number (E); N : node_id; Inner_L : list_id; begin -- Check that the process has been assigned a port number if Port_Number = Properties.No_Value then Display_Located_Error (Loc (Parent_Subcomponent (E)), "This process does not have a port number", Fatal => True); end if; -- The address Inner_L := New_List (ADN.k_list_id); case Protocol is when protocol_diop => Set_Str_To_Name_Buffer ("polyorb.protocols.diop.default_addr"); when others => Set_Str_To_Name_Buffer ("polyorb.protocols.iiop.default_addr"); end case; N := Make_Literal (New_String_Value (Name_Find)); N := Make_Record_Aggregate (Make_List_Id (N)); N := Make_Qualified_Expression (Subtype_Mark => RE (re_string_2), Aggregate => N); N := Make_Object_Instantiation (N); Append_Node_To_List (N, Inner_L); N := Make_Literal (New_String_Value (Location)); N := Make_Record_Aggregate (Make_List_Id (N)); N := Make_Qualified_Expression (Subtype_Mark => RE (re_string_2), Aggregate => N); N := Make_Object_Instantiation (N); Append_Node_To_List (N, Inner_L); N := Make_Record_Aggregate (Inner_L); Append_Node_To_List (N, L); -- The port number Inner_L := New_List (ADN.k_list_id); case Protocol is when protocol_diop => Set_Str_To_Name_Buffer ("polyorb.protocols.diop.default_port"); when others => Set_Str_To_Name_Buffer ("polyorb.protocols.iiop.default_port"); end case; N := Make_Literal (New_String_Value (Name_Find)); N := Make_Record_Aggregate (Make_List_Id (N)); N := Make_Qualified_Expression (Subtype_Mark => RE (re_string_2), Aggregate => N); N := Make_Object_Instantiation (N); Append_Node_To_List (N, Inner_L); Set_Str_To_Name_Buffer (Image (To_Ada_Value (Port_Number))); N := Make_Literal (New_String_Value (Name_Find)); N := Make_Record_Aggregate (Make_List_Id (N)); N := Make_Qualified_Expression (Subtype_Mark => RE (re_string_2), Aggregate => N); N := Make_Object_Instantiation (N); Append_Node_To_List (N, Inner_L); N := Make_Record_Aggregate (Inner_L); Append_Node_To_List (N, L); N := Make_Array_Aggregate (L); return N; end Array_Initialization; --------------------------- -- Partition_Source_Type -- --------------------------- function Partition_Source_Type return node_id is N : node_id; T : node_id; T_Identifier : constant node_id := Make_Defining_Identifier (TN (t_partition_source)); begin T := Make_Derived_Type_Definition (Subtype_Indication => RE (re_parameters_source), Record_Extension_Part => Make_Record_Definition (No_List), Is_Subtype => False); N := Make_Full_Type_Declaration (Defining_Identifier => T_Identifier, Type_Definition => T); return N; end Partition_Source_Type; ------------------------------- -- Partition_Source_Variable -- ------------------------------- function Partition_Source_Variable return node_id is N : node_id; I : node_id; T : node_id; begin I := Make_Defining_Identifier (PN (p_the_partition_source)); T := Make_Defining_Identifier (TN (t_partition_source)); N := Make_Object_Declaration (Defining_Identifier => I, Object_Definition => T, Aliased_Present => True); return N; end Partition_Source_Variable; ------------------- -- Get_Conf_Spec -- ------------------- function Get_Conf_Spec return node_id is Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin N := Make_Parameter_Specification (Make_Defining_Identifier (PN (p_source)), Make_Access_Type_Definition (Make_Defining_Identifier (TN (t_partition_source)))); Append_Node_To_List (N, Profile); N := Make_Parameter_Specification (Make_Defining_Identifier (PN (p_section)), RE (re_string_2)); Append_Node_To_List (N, Profile); N := Make_Parameter_Specification (Make_Defining_Identifier (PN (p_key)), RE (re_string_2)); Append_Node_To_List (N, Profile); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_get_conf)), Parameter_Profile => Profile, Return_Type => RE (re_string_2)); return N; end Get_Conf_Spec; ------------------- -- Get_Conf_Body -- ------------------- function Get_Conf_Body return node_id is Spec : constant node_id := Get_Conf_Spec; Statements : constant list_id := New_List (ADN.k_statement_list); Declarations : constant list_id := New_List (ADN.k_declaration_list); For_Statements : constant list_id := New_List (ADN.k_statement_list); N : node_id; C : node_id; R : node_id; begin -- Declarative part N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (v_temp)), Object_Definition => Make_Defining_Identifier (TN (t_parameter_entry))); Append_Node_To_List (N, Declarations); -- Unused parameters N := Make_Pragma_Statement (pragma_unreferenced, Make_List_Id (Make_Defining_Identifier (PN (p_source)), Make_Defining_Identifier (PN (p_section)))); Append_Node_To_List (N, Declarations); -- The 'for' loop statements N := Make_Assignment_Statement (Make_Defining_Identifier (VN (v_temp)), Make_Subprogram_Call (Make_Defining_Identifier (CN (c_conf_table)), Make_List_Id (Make_Defining_Identifier (VN (v_index))))); Append_Node_To_List (N, For_Statements); -- The inner 'if' statement N := Make_Explicit_Dereference (Make_Selected_Component (Make_Defining_Identifier (VN (v_temp)), Make_Defining_Identifier (PN (p_key)))); C := Make_Expression (N, op_equal, Make_Defining_Identifier (PN (p_key))); N := Make_Return_Statement (Make_Explicit_Dereference (Make_Selected_Component (Make_Defining_Identifier (VN (v_temp)), Make_Defining_Identifier (PN (p_value))))); N := Make_If_Statement (C, Make_List_Id (N)); Append_Node_To_List (N, For_Statements); R := Make_Range_Constraint (Make_Literal (New_Integer_Value (1, 1, 10)), Make_Literal (New_Integer_Value (2, 1, 10))); N := Make_For_Statement (Make_Defining_Identifier (VN (v_index)), R, For_Statements); Append_Node_To_List (N, Statements); -- The last chance return statement N := Make_Return_Statement (Make_Literal (New_String_Value (No_Name))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarations, Statements); return N; end Get_Conf_Body; --------------------- -- Initialize_Spec -- --------------------- function Initialize_Spec return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_initialize)), Parameter_Profile => No_List); return N; end Initialize_Spec; --------------------- -- Initialize_Body -- --------------------- function Initialize_Body return node_id is Spec : constant node_id := Initialize_Spec; Statements : constant list_id := New_List (ADN.k_statement_list); Declarations : constant list_id := New_List (ADN.k_declaration_list); N : node_id; I : node_id; begin I := Make_Defining_Identifier (SN (s_register_source)); N := Make_Attribute_Designator (Make_Defining_Identifier (PN (p_the_partition_source)), a_access); N := Make_Subprogram_Call (I, Make_List_Id (N)); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarations, Statements); return N; end Initialize_Body; ------------------------------- -- Parameters_Initialization -- ------------------------------- function Parameters_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 => RE (re_empty)); Append_Node_To_List (N, Aggregates); -- Provides Set_Str_To_Name_Buffer ("parameters_sources"); N := Make_Literal (New_String_Value (Name_Find)); N := Make_Expression (N, op_plus); N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_provides)), Expression => N); Append_Node_To_List (N, Aggregates); -- Implicit N := Make_Component_Association (Selector_Name => Make_Defining_Identifier (PN (p_implicit)), Expression => RE (re_true)); 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 Parameters_Initialization; end Package_Body; end Ocarina.Generators.PO_QoS_Ada.Parameters;