------------------------------------------------ -------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_QOS_ADA.HELPERS -- -- -- -- 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.Helpers 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.Mapping; use Ocarina.Generators.PO_QoS_Ada.Runtime; use Ocarina.Generators.Ada_Values; package AAN renames Ocarina.Nodes; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; ------------------ -- 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); procedure Visit_Data_Instance (E : node_id); procedure Visit_Subprogram_Instance (E : node_id); function TypeCode_Declaration (E : node_id) return node_id; -- Makes a TypeCode variable declaration corresponding to the -- type definition node given as parameter function From_Any_Spec (E : node_id) return node_id; -- Makes a spec for the 'From_Any' function corresponding to -- the type definition given as a parameter function To_Any_Spec (E : node_id) return node_id; -- Makes a spec for the 'To_Any' function corresponding to -- the type definition given as a parameter ----------- -- 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 cc_subprogram => Visit_Subprogram_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; S : node_id; begin -- Protected objects with accessors are not destined to -- network transfert. They do not have helper routines. if Get_Data_Type (E) = data_with_accessors then return; end if; -- Fixed point types are not supported yet if Get_Data_Type (E) = data_fixed or else Get_Data_Type (E) = data_array then Display_Located_Error (AAN.Loc (E), "Helper generation for this type not supported yet", Fatal => True); end if; Set_Helpers_Spec; if No (Get_Handling (E, by_name, h_ada_helpers_spec)) then N := Message_Comment ("Data type " & Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- For each data type definition, we generate the -- following entities in the Helpers package spec: -- 1) The TypeCode variable N := TypeCode_Declaration (E); Bind_AADL_To_TypeCode (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- 2) The From_Any function spec N := From_Any_Spec (E); Bind_AADL_To_From_Any (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- 2) The To_Any function spec N := To_Any_Spec (E); Bind_AADL_To_To_Any (Identifier (E), N); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); Set_Handling (E, by_name, h_ada_helpers_spec, E); -- Visit the subcomponents of E (if any) if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; else -- This type has already been handled, take the bindings -- correspodning to the first handled instance Bind_AADL_To_TypeCode (Identifier (E), ADN.TypeCode_Node (Backend_Node (Identifier (Get_Handling (E, by_name, h_ada_helpers_spec))))); Bind_AADL_To_From_Any (Identifier (E), ADN.From_Any_Node (Backend_Node (Identifier (Get_Handling (E, by_name, h_ada_helpers_spec))))); Bind_AADL_To_To_Any (Identifier (E), ADN.To_Any_Node (Backend_Node (Identifier (Get_Handling (E, by_name, h_ada_helpers_spec))))); 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); S : node_id; begin Push_Entity (P); Push_Entity (U); -- Start recording all handlings because we want to reset -- them for each node. Start_Recording_Handlings; -- 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; -- Reset all the recorded handlings Reset_Handlings; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is F : node_id; Call_Seq : node_id; Spg_Call : node_id; begin -- Visit all data types if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Present (Corresponding_Instance (F)) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; -- Visit all the call sequences of the subprogram if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Subprogram_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 Call_Seq : node_id; Spg_Call : node_id; F : node_id; begin -- Visit all the thread features if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop Visit (Corresponding_Instance (F)); F := Next_Node (F); end loop; end if; -- Visit all the call sequences of the thread if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Thread_Instance; -------------------------- -- TypeCode_Declaration -- -------------------------- function TypeCode_Declaration (E : node_id) return node_id is V_Identifier : node_id; N : node_id; begin pragma assert (Utils.Is_Data (E)); V_Identifier := Map_TC_Variable_Identifier (E); N := Make_Object_Declaration (Defining_Identifier => V_Identifier, Object_Definition => RE (re_object_ptr)); return N; end TypeCode_Declaration; ------------------- -- From_Any_Spec -- ------------------- function From_Any_Spec (E : node_id) return node_id is Return_Type : node_id; N : node_id; begin pragma assert (Utils.Is_Data (E)); -- Get the Ada type that was mapped from E Return_Type := Map_Ada_Data_Type_Designator (E); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_from_any)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Make_Defining_Identifier (PN (p_item)), RE (re_any))), Return_Type => Return_Type); return N; end From_Any_Spec; ----------------- -- To_Any_Spec -- ----------------- function To_Any_Spec (E : node_id) return node_id is Item_Type : node_id; N : node_id; begin pragma assert (Utils.Is_Data (E)); -- Get the Ada type that was mapped from E Item_Type := Map_Ada_Data_Type_Designator (E); N := Make_Subprogram_Specification (Defining_Identifier => Make_Defining_Identifier (SN (s_to_any)), Parameter_Profile => Make_List_Id (Make_Parameter_Specification (Make_Defining_Identifier (PN (p_item)), Item_Type)), Return_Type => RE (re_any)); return N; end To_Any_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); procedure Visit_Subprogram_Instance (E : node_id); function From_Any_Body (E : node_id) return node_id; -- Makes the body of the From_Any function corresponding to the -- data type E function To_Any_Body (E : node_id) return node_id; -- Makes the body of the To_Any function corresponding to the -- data type E Initialization_Specs : list_id; -- Contains the spec and the flags of the initilization -- routines of all data types Initialization_Bodies : list_id; -- Contains the bodies of the initilization routines of all -- data types function Initialization_Flag_Declaration (E : node_id) return node_id; -- Makes the declaration of the boolean flag that indicates -- wether the type E is already initialized or not function Initialize_Spec (E : node_id) return node_id; -- Makes the spec of the Initialize_ procedure function Initialize_Body (E : node_id) return node_id; -- Makes the body of the Initialize_ procedure function Deferred_Initialization_Spec return node_id; -- Makes the Spec of the deferred initialization procedure function Deferred_Initialization_Body return node_id; -- Makes the body of the deferred initialization procedure function Helper_Initialization return node_id; -- Makes the package initialization routine (which is called at -- the eleboration ----------- -- 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 cc_subprogram => Visit_Subprogram_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; S : node_id; begin -- Protected objects with accessors are not destined to -- network transfert. They do not have helper routines. if Get_Data_Type (E) = data_with_accessors then return; end if; Set_Helpers_Body; if No (Get_Handling (E, by_name, h_ada_helpers_body)) then N := Message_Comment ("Data type " & Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E))); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- For each data type definition, we generate the -- following entities in the Helpers package body: -- 1) The From_Any function body N := From_Any_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 2) The To_Any function body N := To_Any_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- 3) The initialization routines N := Initialization_Flag_Declaration (E); Append_Node_To_List (N, Initialization_Specs); N := Initialize_Spec (E); Append_Node_To_List (N, Initialization_Specs); N := Initialize_Body (E); Append_Node_To_List (N, Initialization_Bodies); Set_Handling (E, by_name, h_ada_helpers_body, N); -- Visit the subcomponents of E (if any) if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; 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); S : node_id; N : node_id; Initialization_Specs_Backup : constant list_id := Initialization_Specs; Initialization_Bodies_Backup : constant list_id := Initialization_Bodies; begin Push_Entity (P); Push_Entity (U); Set_Helpers_Body; Initialization_Specs := New_List (ADN.k_statement_list); Initialization_Bodies := New_List (ADN.k_statement_list); -- Start recording all handlings because we want to reset -- them for each node. Start_Recording_Handlings; -- 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; -- Spec of the deferrend initialization procedure N := Deferred_Initialization_Spec; Append_Node_To_List (N, ADN.Statements (Current_Package)); -- The body of the deferrend initialization procedure N := Deferred_Initialization_Body; -- It's important to append the lists below after the -- building of the deferrend initialization body and before -- the appending this body to the statements of the package -- Append the Initialization spec to statements Append_Node_To_List (ADN.First_Node (Initialization_Specs), ADN.Statements (Current_Package)); -- Append the Initialization bodies to statements Append_Node_To_List (ADN.First_Node (Initialization_Bodies), ADN.Statements (Current_Package)); -- Append the body of the deferrend initialization procedure Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Restaure the old values of the lists Initialization_Specs := Initialization_Specs_Backup; Initialization_Bodies := Initialization_Bodies_Backup; -- Finally, the package initialization: N := Helper_Initialization; ADN.Set_Package_Initialization (Current_Package, New_List (ADN.k_list_id)); Append_Node_To_List (N, ADN.Package_Initialization (Current_Package)); -- Reset all the recorded handlings Reset_Handlings; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is F : node_id; Call_Seq : node_id; Spg_Call : node_id; begin -- Visit all data types if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Present (Corresponding_Instance (F)) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; -- Visit all the call sequences of the subprogram if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Subprogram_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 Call_Seq : node_id; Spg_Call : node_id; F : node_id; begin -- Visit all the thread features if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop Visit (Corresponding_Instance (F)); F := Next_Node (F); end loop; end if; -- Visit all the call sequences of the thread if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Thread_Instance; ------------------- -- From_Any_Body -- ------------------- function From_Any_Body (E : node_id) return node_id is use ADN; Spec : constant node_id := From_Any_Node (Backend_Node (Identifier (E))); Declarative_Part : constant list_id := New_List (k_declaration_list); Statements : constant list_id := New_List (k_statement_list); Data_Type : constant supported_data_type := Get_Data_Type (E); N : node_id; P : node_id; S : node_id; procedure Declare_Predefined_Type_Result (T : node_id); pragma inline (Declare_Predefined_Type_Result); -- Declares the 'Result' constant that corresponds to the -- predefined type T ------------------------------------ -- Declare_Predefined_Type_Result -- ------------------------------------ procedure Declare_Predefined_Type_Result (T : node_id) is begin N := Make_Subprogram_Call (RE (re_from_any_2), Make_List_Id (Make_Defining_Identifier (PN (p_item)))); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_result)), Constant_Present => True, Object_Definition => T, Expression => N); Append_Node_To_List (N, Declarative_Part); end Declare_Predefined_Type_Result; begin -- Declarative part case Data_Type is when data_integer => Declare_Predefined_Type_Result (RE (re_long)); when data_boolean => Declare_Predefined_Type_Result (RE (re_boolean_1)); when data_float => Declare_Predefined_Type_Result (RE (re_float_1)); when data_string => Declare_Predefined_Type_Result (RE (re_string_1)); when data_wide_string => Declare_Predefined_Type_Result (RE (re_wide_string_1)); when data_character => Declare_Predefined_Type_Result (RE (re_character_1)); when data_wide_character => Declare_Predefined_Type_Result (RE (re_wide_character_1)); when data_record => -- Declare a temporary variable to store the fields -- values N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (v_index)), Object_Definition => RE (re_any)); Append_Node_To_List (N, Declarative_Part); -- For each field of the record, a variable having the -- type of this field. S := AAN.First_Node (Subcomponents (E)); while Present (S) loop N := Make_Object_Declaration (Defining_Identifier => Map_Record_Field_Identifier (S), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (S))); Append_Node_To_List (N, Declarative_Part); S := AAN.Next_Node (S); end loop; when others => -- This cannot happen raise Program_Error; end case; -- Statements case Data_Type is when data_integer | data_boolean | data_float | data_character | data_wide_character => N := Make_Type_Conversion (Map_Ada_Data_Type_Designator (E), Make_Defining_Identifier (PN (p_result))); when data_string => N := Make_Subprogram_Call (RE (re_to_standard_string), Make_List_Id (Make_Defining_Identifier (PN (p_result)))); P := Make_Defining_Identifier (SN (s_to_bounded_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Subprogram_Call (P, Make_List_Id (N)); N := Make_Type_Conversion (Map_Ada_Data_Type_Designator (E), N); when data_wide_string => N := Make_Subprogram_Call (RE (re_to_standard_wide_string), Make_List_Id (Make_Defining_Identifier (PN (p_result)))); P := Make_Defining_Identifier (SN (s_to_bounded_wide_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Subprogram_Call (P, Make_List_Id (N)); N := Make_Type_Conversion (Map_Ada_Data_Type_Designator (E), N); when data_record => declare Aggregate_List : constant list_id := New_List (k_list_id); Index : unsigned_long_long := 0; C_Instance : node_id; begin S := AAN.First_Node (Subcomponents (E)); while Present (S) loop -- Get the correspodning data instance C_Instance := Corresponding_Instance (S); -- Get a designator for the TypeCode variable N := Extract_Designator (TypeCode_Node (Backend_Node (Identifier (C_Instance)))); N := Make_Subprogram_Call (RE (re_to_ref), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_get_aggregate_element), Make_List_Id (Make_Defining_Identifier (PN (p_item)), N, Make_Literal (New_Integer_Value (Index, 1, 10)))); N := Make_Assignment_Statement (Make_Defining_Identifier (VN (v_index)), N); Append_Node_To_List (N, Statements); N := Make_Subprogram_Call (Extract_Designator (From_Any_Node (Backend_Node (Identifier (C_Instance)))), Make_List_Id (Make_Defining_Identifier (VN (v_index)))); -- The Result_ variable N := Make_Assignment_Statement (Map_Record_Field_Identifier (S), N); Append_Node_To_List (N, Statements); -- Make a component association and append it to -- the final result. N := Make_Component_Association (Map_Ada_Defining_Identifier (S), Map_Record_Field_Identifier (S)); Append_Node_To_List (N, Aggregate_List); Index := Index + 1; S := AAN.Next_Node (S); end loop; N := Make_Record_Aggregate (Aggregate_List); end; when others => -- This cannot happen raise Program_Error; end case; N := Make_Return_Statement (N); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarative_Part, Statements); return N; end From_Any_Body; ----------------- -- To_Any_Body -- ----------------- function To_Any_Body (E : node_id) return node_id is use ADN; Spec : constant node_id := To_Any_Node (Backend_Node (Identifier (E))); Declarative_Part : constant list_id := New_List (k_declaration_list); Statements : constant list_id := New_List (k_statement_list); Data_Type : constant supported_data_type := Get_Data_Type (E); N : node_id; P : node_id; S : node_id; procedure Declare_Predefined_Type_Result (V : node_id); pragma inline (Declare_Predefined_Type_Result); -- Declares the 'Result' which is the Any value -- corresponding to the predfined type value V procedure Predefined_Type_Statements (E : node_id); pragma inline (Predefined_Type_Statements); -- Makes the To_Any statments in case of a predefined type E ------------------------------------ -- Declare_Predefined_Type_Result -- ------------------------------------ procedure Declare_Predefined_Type_Result (V : node_id) is begin N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (V)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_result)), Object_Definition => RE (re_any), Expression => N); Append_Node_To_List (N, Declarative_Part); end Declare_Predefined_Type_Result; -------------------------------- -- Predefined_Type_Statements -- -------------------------------- procedure Predefined_Type_Statements (E : node_id) is begin N := Extract_Designator (TypeCode_Node (Backend_Node (Identifier (E)))); N := Make_Subprogram_Call (RE (re_set_type), Make_List_Id (Make_Defining_Identifier (PN (p_result)), N)); Append_Node_To_List (N, Statements); N := Make_Return_Statement (Make_Defining_Identifier (PN (p_result))); Append_Node_To_List (N, Statements); end Predefined_Type_Statements; begin -- Declarative part case Data_Type is when data_integer => N := Make_Type_Conversion (RE (re_long), Make_Defining_Identifier (PN (p_item))); Declare_Predefined_Type_Result (N); when data_float => N := Make_Type_Conversion (RE (re_float_1), Make_Defining_Identifier (PN (p_item))); Declare_Predefined_Type_Result (N); when data_boolean => N := Make_Type_Conversion (RE (re_boolean_1), Make_Defining_Identifier (PN (p_item))); Declare_Predefined_Type_Result (N); when data_character => N := Make_Type_Conversion (RE (re_character_1), Make_Defining_Identifier (PN (p_item))); Declare_Predefined_Type_Result (N); when data_wide_character => N := Make_Type_Conversion (RE (re_wide_character_1), Make_Defining_Identifier (PN (p_item))); Declare_Predefined_Type_Result (N); when data_string => P := Make_Defining_Identifier (TN (t_bounded_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Type_Conversion (P, Make_Defining_Identifier (PN (p_item))); P := Make_Defining_Identifier (SN (s_to_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Subprogram_Call (P, Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_to_polyorb_string), Make_List_Id (N)); Declare_Predefined_Type_Result (N); when data_wide_string => P := Make_Defining_Identifier (TN (t_bounded_wide_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Type_Conversion (P, Make_Defining_Identifier (PN (p_item))); P := Make_Defining_Identifier (SN (s_to_wide_string)); Set_Homogeneous_Parent_Unit_Name (P, Map_Package_Instantiation_Designator (E)); N := Make_Subprogram_Call (P, Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_to_polyorb_wide_string), Make_List_Id (N)); Declare_Predefined_Type_Result (N); when data_record => -- The Result variable N := Extract_Designator (TypeCode_Node (Backend_Node (Identifier (E)))); N := Make_Subprogram_Call (RE (re_to_ref), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_get_empty_any_aggregate), Make_List_Id (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_result)), Object_Definition => RE (re_any), Expression => N); Append_Node_To_List (N, Declarative_Part); when others => -- This cannot happen raise Program_Error; end case; -- Statements case Data_Type is when data_integer | data_float | data_boolean | data_character | data_wide_character | data_string | data_wide_string => Predefined_Type_Statements (E); when data_record => declare C_Instance : node_id; begin S := AAN.First_Node (Subcomponents (E)); while Present (S) loop C_Instance := Corresponding_Instance (S); N := Make_Selected_Component (Make_Defining_Identifier (PN (p_item)), Map_Ada_Defining_Identifier (S)); N := Make_Subprogram_Call (Extract_Designator (To_Any_Node (Backend_Node (Identifier (C_Instance)))), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_add_aggregate_element), Make_List_Id (Make_Defining_Identifier (PN (p_result)), N)); Append_Node_To_List (N, Statements); S := AAN.Next_Node (S); end loop; N := Make_Return_Statement (Make_Defining_Identifier (PN (p_result))); Append_Node_To_List (N, Statements); end; when others => -- This cannot happen raise Program_Error; end case; N := Make_Subprogram_Implementation (Spec, Declarative_Part, Statements); return N; end To_Any_Body; ------------------------------------- -- Initialization_Flag_Declaration -- ------------------------------------- function Initialization_Flag_Declaration (E : node_id) return node_id is N : node_id; begin N := Make_Object_Declaration (Defining_Identifier => Map_Initialized_Flag_Identifier (E), Object_Definition => RE (re_boolean_2), Expression => RE (re_false)); return N; end Initialization_Flag_Declaration; --------------------- -- Initialize_Spec -- --------------------- function Initialize_Spec (E : node_id) return node_id is N : node_id; begin N := Make_Subprogram_Specification (Defining_Identifier => Map_Initialize_Identifier (E), Parameter_Profile => No_List, Return_Type => No_Node); return N; end Initialize_Spec; --------------------- -- Initialize_Body -- --------------------- function Initialize_Body (E : node_id) return node_id is use ADN; Spec : constant node_id := Initialize_Spec (E); Declarative_Part : constant list_id := New_List (k_declaration_list); Statements : constant list_id := New_List (k_statement_list); Data_Type : constant supported_data_type := Get_Data_Type (E); N : node_id; TC : node_id; S : node_id; Type_Name : name_id := AAN.Name (Identifier (E)); If_Statements : constant list_id := New_List (k_statement_list); begin -- Mark the type as initialized N := Make_Assignment_Statement (Map_Initialized_Flag_Identifier (E), RE (re_true)); Append_Node_To_List (N, If_Statements); -- Common declarations and statements case Data_Type is when data_integer | data_float | data_boolean | data_character | data_wide_character | data_string | data_wide_string | data_record => -- 1) The 'Name' variable N := Make_Literal (New_String_Value (Type_Name)); N := Make_Subprogram_Call (RE (re_to_polyorb_string), Make_List_Id (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_name)), Constant_Present => True, Object_Definition => RE (re_string_1), Expression => N); Append_Node_To_List (N, Declarative_Part); -- 1) The 'Id' variable N := Make_Literal (New_String_Value (Add_Suffix_To_Name (":1.0", Type_Name))); N := Make_Subprogram_Call (RE (re_to_polyorb_string), Make_List_Id (N)); N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_id)), Constant_Present => True, Object_Definition => RE (re_string_1), Expression => N); Append_Node_To_List (N, Declarative_Part); -- 2) The 'Type_Code' variable if Data_Type = data_record then N := RE (re_tc_struct); else N := RE (re_tc_alias); end if; -- Declare the TypeCode reference N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_type_code)), Constant_Present => True, Object_Definition => RE (re_local_ref), Expression => N); Append_Node_To_List (N, Declarative_Part); -- Append the 'Name' parameter N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (Make_Defining_Identifier (PN (p_name)))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); -- Append the 'Id' parameter N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (Make_Defining_Identifier (PN (p_id)))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when others => null; end case; -- Specific declarations and statements case Data_Type is when data_integer => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_long))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_float => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_float))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_boolean => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_boolean))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_character => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_character))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_wide_character => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_wide_character))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_string => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_string))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_wide_string => N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (RE (re_tc_wide_string))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); when data_record => declare C_Instance : node_id; begin S := AAN.First_Node (Subcomponents (E)); while Present (S) loop C_Instance := Corresponding_Instance (S); -- 1) Declare a variable which will cntain the -- field name Type_Name := AAN.Name (Identifier (S)); N := Make_Literal (New_String_Value (Type_Name)); N := Make_Subprogram_Call (RE (re_to_polyorb_string), Make_List_Id (N)); N := Make_Object_Declaration (Defining_Identifier => Map_Record_Field_Identifier (S), Constant_Present => True, Object_Definition => RE (re_string_1), Expression => N); Append_Node_To_List (N, Declarative_Part); -- 2) Initialize the data type corresponding to -- the aggregate N := Make_Subprogram_Call (Map_Initialize_Identifier (C_Instance), No_List); Append_Node_To_List (N, If_Statements); -- 3) Add the parameter corresponding to the -- TypeCode of the aggregate N := Extract_Designator (TypeCode_Node (Backend_Node (Identifier (C_Instance)))); N := Make_Subprogram_Call (RE (re_to_ref), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (N)); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); -- 4) Add the parameter corresponding to the -- aggregate name N := Make_Subprogram_Call (RE (re_to_any_2), Make_List_Id (Map_Record_Field_Identifier (S))); N := Make_Subprogram_Call (RE (re_add_parameter), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)), N)); Append_Node_To_List (N, If_Statements); S := AAN.Next_Node (S); end loop; end; when others => -- This cannot happen raise Program_Error; end case; -- Get the TypeCode object access TC := Extract_Designator (TypeCode_Node (Backend_Node (Identifier (E)))); -- Assign the value of the TypeCode object N := Make_Subprogram_Call (RE (re_object_of), Make_List_Id (Make_Defining_Identifier (PN (p_type_code)))); N := Make_Assignment_Statement (TC, N); Append_Node_To_List (N, If_Statements); -- Disable reference counting on the TypeCode object N := Make_Subprogram_Call (RE (re_disable_reference_counting), Make_List_Id (Make_Explicit_Dereference (TC))); Append_Node_To_List (N, If_Statements); -- Build the 'if' statements N := Make_Expression (Map_Initialized_Flag_Identifier (E), op_not); N := Make_If_Statement (N, If_Statements); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, Declarative_Part, Statements); return N; end Initialize_Body; ---------------------------------- -- Deferred_Initialization_Spec -- ---------------------------------- function Deferred_Initialization_Spec return node_id is begin return Make_Subprogram_Specification (Make_Defining_Identifier (SN (s_deferred_initialization)), No_List, No_Node); end Deferred_Initialization_Spec; ---------------------------------- -- Deferred_Initialization_Body -- ---------------------------------- function Deferred_Initialization_Body return node_id is use ADN; Spec : constant node_id := Deferred_Initialization_Spec; Statements : constant list_id := New_List (k_statement_list); S : node_id; N : node_id; begin -- This function call all the Initialize_XXXX procedures S := ADN.First_Node (Initialization_Specs); while Present (S) loop if ADN.Kind (S) = k_subprogram_specification then N := Make_Subprogram_Call (Copy_Node (Defining_Identifier (S)), No_List); Append_Node_To_List (N, Statements); end if; S := ADN.Next_Node (S); end loop; N := Make_Subprogram_Implementation (Spec, No_List, Statements); return N; end Deferred_Initialization_Body; --------------------------- -- Helper_Initialization -- --------------------------- function Helper_Initialization return node_id is use ADN; N : node_id; V : value_id; Aggregates : constant list_id := New_List (k_component_list); Declarative_Part : constant list_id := New_List (k_declaration_list); Statements : constant list_id := New_List (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 := Defining_Identifier (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_deferred_initialization)), 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 Helper_Initialization; end Package_Body; end Ocarina.Generators.PO_QoS_Ada.Helpers;