------------------------------------- ------------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_QOS_ADA.NAMESPACES -- -- -- -- 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 Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components; with Ocarina.Generators.Utils; with Ocarina.Generators.Properties; with Ocarina.Generators.Messages; with Ocarina.Generators.PO_QoS_Ada.Mapping; with Ocarina.Generators.PO_QoS_Ada.Runtime; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_QoS_Ada.Namespaces is use Ocarina.Nodes; use Ocarina.Entities.Components; 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_Tree.Nutils; use Ocarina.Generators.Ada_Values; package AAN renames Ocarina.Nodes; package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; package ADU renames Ocarina.Generators.Ada_Tree.Nutils; ------------------ -- 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_Namespace_Instance (E : node_id); procedure Visit_Data_Instance (E : node_id); procedure Visit_Subprogram_Instance (E : node_id); Current_Architecture_Instance : node_id; -- Points to the root of the instance tree Current_Process_Instance : node_id; -- Points to the current visited AADL process instance function Get_Ada_Unit (E : node_id) return node_id; pragma inline (Get_Ada_Unit); -- Return the Ada unit inside which the data or subprogram -- component E has to be generated. function Protected_Type_Routines (E : node_id; Components : list_id) return list_id; -- Declares the routines corresponding to a protected AADL data -- component. Components is pre-built list of Ada component -- declaration corresponding to the data subcomponents. ------------------ -- Get_Ada_Unit -- ------------------ function Get_Ada_Unit (E : node_id) return node_id is N : node_id; P : node_id; U : node_id; begin pragma assert (Utils.Is_Data (E) or else Utils.Is_Subprogram (E)); N := Namespace (E); P := ADN.Namespaces_Node (Backend_Node (Bind_Two_Nodes (N, Current_Process_Instance))); U := ADN.Distributed_Application_Unit (P); return U; end Get_Ada_Unit; ----------- -- 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 k_namespace_instance => Visit_Namespace_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : node_id) is begin Current_Architecture_Instance := E; 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 U : constant node_id := Get_Ada_Unit (E); Data_Type : supported_data_type; N : node_id; S : node_id; begin -- Push the Ada unit correspoding to the AADL namespace Push_Entity (U); Set_Namespaces_Spec; -- Do not generate Ada type more than once if No (Get_Handling (E, by_name, h_ada_namespaces_spec)) then -- FIXME: For now, strings and arrays are unsupported -- The code generation for the following types is not yet -- supported: Arrays and bounded strings. Data_Type := Get_Data_Type (E); case Data_Type is when data_integer => N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (RE (re_integer))); when data_float => N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (RE (re_float_2))); when data_fixed => declare Data_Digits : constant unsigned_long_long := Get_Data_Digits (E); Data_Scale : constant unsigned_long_long := Get_Data_Scale (E); begin if Data_Digits /= 0 and then Data_Scale /= 0 then N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Decimal_Type_Definition (Data_Digits, Data_Scale)); else if Data_Digits = 0 then Display_Located_Error (Loc (E), "Missing the digit number of fixed point type!", Fatal => True); end if; if Data_Scale = 0 then Display_Located_Error (Loc (E), "Missing the scale of fixed point type!", Fatal => True); end if; end if; end; when data_boolean => N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (RE (re_boolean_2))); when data_character => N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (RE (re_character_2))); when data_wide_character => N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (RE (re_wide_character_2))); when data_string => -- Bounded string data types require special -- handling: we don't map string to the -- 'Standard.String' type since this is an -- unconstrained type and would prevent us to build -- data structures (buffers, records) with it. So -- we use the Ada.Strings.Bounded packages N := Make_Package_Instantiation (Defining_Identifier => Map_Package_Identifier (E), Generic_Package => RU (ru_ada_strings_bounded_generic_bounded_length), Parameter_List => Make_List_Id (Make_Literal (New_Integer_Value (Get_Data_Length (E), 1, 10)))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (Make_Selected_Component (Map_Package_Identifier (E), Make_Defining_Identifier (TN (t_bounded_string))))); when data_wide_string => -- Bounded wide string data types require special -- handling: we don't map string to the -- 'Standard.Wide_String' type since this is an -- unconstrained type and would prevent us to build -- data structures (buffers, records) with it. So -- we use the Ada.Strings.Wide_Bounded packages N := Make_Package_Instantiation (Defining_Identifier => Map_Package_Identifier (E), Generic_Package => RU (ru_ada_strings_wide_bounded_generic_bounded_length), Parameter_List => Make_List_Id (Make_Literal (New_Integer_Value (Get_Data_Length (E), 1, 10)))); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Derived_Type_Definition (Make_Selected_Component (Map_Package_Identifier (E), Make_Defining_Identifier (TN (t_bounded_wide_string))))); Display_Located_Error (Loc (E), "Bounded wide strings not supported yet!", Fatal => True); when data_array => Display_Located_Error (Loc (E), "Bounded arrays not supported yet!", Fatal => True); when data_record | data_with_accessors => declare Components : constant list_id := New_List (ADN.k_component_list); Conc_Proto : constant supported_concurrency_control_protocol := Get_Concurrency_Protocol (E); C : node_id := First_Node (Subcomponents (E)); L : list_id; begin -- Build the component list while Present (C) loop -- Generate the Ada type corresponding to the -- subcomponent. Visit (Corresponding_Instance (C)); -- Make the record or private type component N := Make_Component_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (C), Subtype_Indication => Map_Ada_Data_Type_Designator (Corresponding_Instance (C))); Append_Node_To_List (N, Components); C := Next_Node (C); end loop; if Data_Type = data_record and then Conc_Proto = concurrency_nonespecified then -- Simple record type N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Record_Type_Definition (Make_Record_Definition (Components))); elsif Conc_Proto = concurrency_protected_access then -- Protected type L := Protected_Type_Routines (E, Components); -- The first element of the list L is the -- protected type declaration. N := ADN.First_Node (L); else Display_Located_Error (Loc (E), "Unsupported concurrency protocol " & Conc_Proto'img, Fatal => True); end if; end; when others => Display_Located_Error (Loc (E), "Unsupported data type!", Fatal => True); end case; -- Mark the data type as being handled. Set_Handling (E, by_name, h_ada_namespaces_spec, N); -- In the case of a data type with accessor, visit the -- parameters of its features subprograms. It is -- important to do this *after* marking the type as -- handled, to avoid endless loops and *before* adding -- the type declaration to the package statements because -- the declaration order of type is important in Ada. In -- parallel, we visit the subprograms to create their -- specs if Data_Type = data_with_accessors then S := First_Node (Features (E)); while Present (S) loop Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; -- Append the type declaration to the package spec Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); end if; -- Bind the type to its mapping Bind_AADL_To_Type_Definition (Identifier (E), Get_Handling (E, by_name, h_ada_namespaces_spec)); Pop_Entity; -- U end Visit_Data_Instance; ------------------------------ -- Visit_Namespace_Instance -- ------------------------------ procedure Visit_Namespace_Instance (E : node_id) is U : constant node_id := Map_QoS_Unit (E, Current_Process_Instance); pragma unreferenced (U); -- Not read begin null; end Visit_Namespace_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is P : constant node_id := Map_QoS_Node (E); U : node_id; pragma unreferenced (U); N : node_id; S : node_id; begin Current_Process_Instance := E; Push_Entity (P); -- It is important to push P before creating U U := Map_QoS_Unit (E); -- Do not push U. We just need to ensure the creation of the -- main subprogram node before the namespace node. -- We begin by visiting all the namespaces of the current -- architecture instance. Note that this is necessary for -- creating the empty packages corresponding to each -- namespace instance. It is important to do this after -- pushing the entity corresponding to the node at the top -- of the entity stack so that the namespace packages would -- be attched to the current node. Note also that generating -- an empty package for each namespace does not necessarily -- imply the generation of a source file. Only the packages -- that contain declarations (depending on the current node) -- will be generated. -- Visit the unnamed namespace of the current archirtecture -- instance. if Present (Unnamed_Namespace (Current_Architecture_Instance)) then Visit (Unnamed_Namespace (Current_Architecture_Instance)); else -- This is an instantiation error Display_Located_Error (Loc (Current_Architecture_Instance), "This AADL architecture has no unnamed namespace", Fatal => True); end if; -- Visit all the namespace instances of the architecture -- instance. if not AAU.Is_Empty (AAN.Namespaces (Current_Architecture_Instance)) then N := First_Node (AAN.Namespaces (Current_Architecture_Instance)); while Present (N) loop Visit (N); N := Next_Node (N); end loop; end if; -- After creating the package declarations, we need to set, -- for each package declaration generating from a namespace -- instance, its corresponding parent package -- declaration. This has to be done *after* creating all -- package declarations because in AADL, we can declare a -- child package *before* it parent. This has to be done -- only for the namespaces corresponding to AADL packages -- (the unnamed namespace has no parent). if not AAU.Is_Empty (AAN.Namespaces (Current_Architecture_Instance)) then N := First_Node (AAN.Namespaces (Current_Architecture_Instance)); while Present (N) loop declare Pkg_Dcl : constant node_id := ADN.Namespaces_Node (Backend_Node (Bind_Two_Nodes (N, Current_Process_Instance))); Parent_Id : constant node_id := ADN.Parent_Unit_Name (ADN.Defining_Identifier (Pkg_Dcl)); begin if Present (Pkg_Dcl) then ADN.Set_Parent (Pkg_Dcl, Get_Bound_Package (Parent_Id)); end if; end; N := Next_Node (N); end loop; end if; -- Now that all the namespace packages are created, we visit -- recursively all the subcomponents of the process and map -- them to their corresponding packages. -- Start recording all handlings because we want to reset -- them for each node. Start_Recording_Handlings; 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; -- After all the entities are generated in the namespaces -- packages, we must ensure that, for each package P.Q, the -- parent spec P is generated even if P has no declarations. if not AAU.Is_Empty (AAN.Namespaces (Current_Architecture_Instance)) then N := First_Node (AAN.Namespaces (Current_Architecture_Instance)); while Present (N) loop declare Pkg_Dcl : constant node_id := ADN.Namespaces_Node (Backend_Node (Bind_Two_Nodes (N, Current_Process_Instance))); Parent_Dcl : node_id; Parent_Spec : node_id; begin Parent_Dcl := ADN.Parent (Pkg_Dcl); while Present (Parent_Dcl) loop Parent_Spec := ADN.Package_Specification (Parent_Dcl); if ADU.Is_Empty (ADN.Visible_Part (Parent_Spec)) and then ADU.Is_Empty (ADN.Private_Part (Parent_Spec)) then Append_Node_To_List (Message_Comment ("This package specification has to be generated" & " because it has at least one child package"), ADN.Visible_Part (Parent_Spec)); end if; Parent_Dcl := ADN.Parent (Parent_Dcl); end loop; end; N := Next_Node (N); end loop; end if; -- Reset all the recorded handlings Reset_Handlings; Pop_Entity; -- P end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is U : constant node_id := Get_Ada_Unit (E); N : node_id; F : node_id; Call_Seq : node_id; Spg_Call : node_id; begin -- Declare all necessary data types if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance then Display_Located_Error (Loc (F), "Port features in subprogram are not supported", Fatal => True); end if; if Present (Corresponding_Instance (F)) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; if No (Get_Handling (E, by_name, h_ada_namespaces_spec)) then -- Push the Ada unit correspoding to the AADL namespace Push_Entity (U); Set_Namespaces_Spec; N := Map_Ada_Subprogram_Spec (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- Mark the data type as being handled Set_Handling (E, by_name, h_ada_namespaces_spec, N); -- If the subprogram is hybrid, generate extra -- declarations. if Get_Subprogram_Kind (E) = subprogram_hybrid_ada_95 then -- The status record type declaration N := Map_Ada_Subprogram_Status (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); -- The subprogram access type N := Map_Ada_Call_Seq_Access (E); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence create a subprogram spec N := Map_Ada_Call_Seq_Subprogram_Spec (E, Call_Seq); Append_Node_To_List (N, ADN.Visible_Part (Current_Package)); Call_Seq := Next_Node (Call_Seq); end loop; end if; Pop_Entity; -- U end if; Bind_AADL_To_Subprogram (Identifier (E), Get_Handling (E, by_name, h_ada_namespaces_spec)); -- 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 D : node_id; S : node_id; begin D := Map_Distributed_Application (E); Push_Entity (D); 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; 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; ----------------------------- -- Protected_Type_Routines -- ----------------------------- function Protected_Type_Routines (E : node_id; Components : list_id) return list_id is Routines : constant list_id := New_List (ADN.k_statement_list); N : node_id; A : node_id; Accessor : name_id; begin -- Declare the private type in the package visible part -- (which is the Routines list) N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Private_Type_Definition); Append_Node_To_List (N, Routines); -- Decalre the full type in the parivate part of the package -- Add mutex field to the component list N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (VN (v_mutex)), Object_Definition => RE (re_mutex_access)); Append_Node_To_List (N, Components); N := Make_Full_Type_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (E), Type_Definition => Make_Record_Type_Definition (Make_Record_Definition (Components))); Append_Node_To_List (N, ADN.Private_Part (Current_Package)); -- Specification of the subprogram that builds one instance -- of the protected type. N := Make_Subprogram_Specification (Make_Defining_Identifier (SN (s_build)), Make_List_Id (Make_Parameter_Specification (Make_Defining_Identifier (PN (p_self)), Map_Ada_Defining_Identifier (E), mode_out))); Append_Node_To_List (N, Routines); Bind_AADL_To_Build (Identifier (E), N); -- For each field, create an accessor subprogram -- specification. A := First_Node (Subcomponents (E)); while Present (A) loop -- Setter spec Accessor := Add_Prefix_To_Name ("Set_", To_Ada_Name (Name (Identifier (A)))); N := Make_Subprogram_Specification (Make_Defining_Identifier (Accessor), Make_List_Id (Make_Parameter_Specification (Make_Defining_Identifier (PN (p_self)), Map_Ada_Defining_Identifier (E), mode_inout), Make_Parameter_Specification (Make_Defining_Identifier (PN (p_value)), Map_Ada_Data_Type_Designator (Corresponding_Instance (A))))); Append_Node_To_List (N, Routines); Bind_AADL_To_Set (Identifier (A), N); -- Getter spec Accessor := Add_Prefix_To_Name ("Get_", To_Ada_Name (Name (Identifier (A)))); N := Make_Subprogram_Specification (Make_Defining_Identifier (Accessor), Make_List_Id (Make_Parameter_Specification (Make_Defining_Identifier (PN (p_self)), Map_Ada_Defining_Identifier (E), mode_in), Make_Parameter_Specification (Make_Defining_Identifier (PN (p_value)), Map_Ada_Data_Type_Designator (Corresponding_Instance (A)), mode_out))); Append_Node_To_List (N, Routines); Bind_AADL_To_Get (Identifier (A), N); A := Next_Node (A); end loop; return Routines; end Protected_Type_Routines; 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); Current_Process_Instance : node_id; -- Points to the current visited AADL process instance function Get_Ada_Unit (E : node_id) return node_id; pragma inline (Get_Ada_Unit); -- Return the Ada unit inside which the data or subprogram -- component E has to be generated. function Protected_Type_Routines (E : node_id) return list_id; -- Declares the routines corresponding to a protected AADL data -- component. Components is pre-built list of Ada component -- declaration corresponding to the data subcomponents. ------------------ -- Get_Ada_Unit -- ------------------ function Get_Ada_Unit (E : node_id) return node_id is N : node_id; P : node_id; U : node_id; begin pragma assert (Utils.Is_Data (E) or else Utils.Is_Subprogram (E)); N := Namespace (E); P := ADN.Namespaces_Node (Backend_Node (Bind_Two_Nodes (N, Current_Process_Instance))); U := ADN.Distributed_Application_Unit (P); return U; end Get_Ada_Unit; ----------- -- 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 U : constant node_id := Get_Ada_Unit (E); Data_Type : supported_data_type; N : node_id; begin -- Push the Ada unit correspoding to the AADL namespace Push_Entity (U); Set_Namespaces_Body; if No (Get_Handling (E, by_name, h_ada_namespaces_body)) then Data_Type := Get_Data_Type (E); case Data_Type is when data_with_accessors | data_record => declare Conc_Proto : constant supported_concurrency_control_protocol := Get_Concurrency_Protocol (E); C : node_id := First_Node (Subcomponents (E)); L : list_id; S : node_id; begin -- Visit the subcomponents while Present (C) loop Visit (Corresponding_Instance (C)); C := Next_Node (C); end loop; if Conc_Proto = concurrency_protected_access then -- Protected type L := Protected_Type_Routines (E); N := ADN.First_Node (L); Append_Node_To_List (N, ADN.Statements (Current_Package)); end if; -- Mark the data type as being handled Set_Handling (E, by_name, h_ada_namespaces_body, E); -- Bodies of the subprogram features. It is -- important to do this *after* marking the type -- as being visited to avoid endless recursion. if Data_Type = data_with_accessors then S := First_Node (Features (E)); while Present (S) loop Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end; when others => null; end case; end if; Pop_Entity; -- U end Visit_Data_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is S : node_id; begin Current_Process_Instance := E; -- Visit recursively all the subcomponents of the process -- and map them to their corresponding packages. -- Start recording all handlings because we want to reset -- them for each node. Start_Recording_Handlings; 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; end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is U : constant node_id := Get_Ada_Unit (E); N : node_id; F : node_id; Call_Seq : node_id; Spg_Call : node_id; begin -- Declare all necessary 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; -- Generate the body of the subprogram if No (Get_Handling (E, by_name, h_ada_namespaces_body)) then Push_Entity (U); Set_Namespaces_Body; N := Map_Ada_Subprogram_Body (E); Append_Node_To_List (N, ADN.Statements (Current_Package)); -- Mark the data type as being handled Set_Handling (E, by_name, h_ada_namespaces_body, N); -- If the subprogram is hybrid, generate extra entities if Get_Subprogram_Kind (E) = subprogram_hybrid_ada_95 then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence create a subprogram body N := Map_Ada_Call_Seq_Subprogram_Body (E, Call_Seq); Append_Node_To_List (N, ADN.Statements (Current_Package)); Call_Seq := Next_Node (Call_Seq); end loop; end if; 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; ----------------------------- -- Protected_Type_Routines -- ----------------------------- function Protected_Type_Routines (E : node_id) return list_id is Routines : constant list_id := New_List (ADN.k_statement_list); N : node_id; A : node_id; Spec : node_id; Statements : list_id; begin -- Builder implementation Spec := ADN.Build_Node (Backend_Node (Identifier (E))); Statements := New_List (ADN.k_statement_list); N := Make_Subprogram_Call (RE (re_create_2), Make_List_Id (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Make_Defining_Identifier (VN (v_mutex))))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, No_List, Statements); Append_Node_To_List (N, Routines); A := First_Node (Subcomponents (E)); while Present (A) loop -- Setter implementation Spec := ADN.Set_Node (Backend_Node (Identifier (A))); Statements := New_List (ADN.k_statement_list); N := Make_Subprogram_Call (RE (re_enter), Make_List_Id (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Make_Defining_Identifier (VN (v_mutex))))); Append_Node_To_List (N, Statements); N := Make_Assignment_Statement (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Map_Ada_Defining_Identifier (A)), Make_Defining_Identifier (PN (p_value))); ADU.Append_Node_To_List (N, Statements); N := Make_Subprogram_Call (RE (re_leave), Make_List_Id (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Make_Defining_Identifier (VN (v_mutex))))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, No_List, Statements); ADU.Append_Node_To_List (N, Routines); -- Getter implementation Spec := ADN.Get_Node (Backend_Node (Identifier (A))); Statements := New_List (ADN.k_statement_list); N := Make_Subprogram_Call (RE (re_enter), Make_List_Id (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Make_Defining_Identifier (VN (v_mutex))))); Append_Node_To_List (N, Statements); N := Make_Assignment_Statement (Make_Defining_Identifier (PN (p_value)), Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Map_Ada_Defining_Identifier (A))); ADU.Append_Node_To_List (N, Statements); N := Make_Subprogram_Call (RE (re_leave), Make_List_Id (Make_Selected_Component (Make_Defining_Identifier (PN (p_self)), Make_Defining_Identifier (VN (v_mutex))))); Append_Node_To_List (N, Statements); N := Make_Subprogram_Implementation (Spec, No_List, Statements); ADU.Append_Node_To_List (N, Routines); A := Next_Node (A); end loop; return Routines; end Protected_Type_Routines; end Package_Body; end Ocarina.Generators.PO_QoS_Ada.Namespaces;