---------------------------------------- ---------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_QOS_ADA.MAPPING -- -- -- -- 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 GNAT.Case_Util; with Namet; use Namet; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Generators.Utils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.PO_QoS_Ada.Runtime; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.PO_QoS_Ada.Mapping is use Ocarina.Nodes; use Ocarina.Generators.Utils; use Ocarina.Generators.Ada_Tree.Nodes; use Ocarina.Generators.Ada_Tree.Nutils; 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; function Package_Binding_Internal_Name (I : node_id) return name_id; -- For code factorization purpose between -- Bind_Ada_Identifier_To_Package and Get_Bound_Package. function Get_Servant_Internal_Name (Entity : node_id) return name_id; -- Return a conventional used to bind entities to servant numbers -- and indices. --------------------------------- -- Map_Distributed_Application -- --------------------------------- function Map_Distributed_Application (E : node_id) return node_id is D : constant node_id := New_Node (ADN.k_qos_distributed_application); begin pragma assert (Is_System (E)); -- Update the global variable to be able to fetch the root of -- the distributed application and generate the source files. QoS_Distributed_Application_Root := D; ADN.Set_Name (D, To_Ada_Name (AAN.Display_Name (AAN.Identifier (E)))); ADN.Set_QoS_Nodes (D, New_List (ADN.k_list_id)); return D; end Map_Distributed_Application; ------------------ -- Map_QoS_Node -- ------------------ function Map_QoS_Node (E : node_id) return node_id is N : constant node_id := New_Node (ADN.k_qos_node); begin pragma assert (Is_Process (E)); -- The name of the node is not the name of the process -- component instance, but the name of the process subcomponent -- corresponding to this instance. ADN.Set_Name (N, To_Ada_Name (AAN.Display_Name (AAN.Identifier (AAN.Parent_Subcomponent (E))))); Set_Units (N, New_List (k_list_id)); -- Append the partition N to the node list of the PolyORB-HI -- distributed application. We are sure that the top of the -- entity stack contains the Ada distrubuted application node. Append_Node_To_List (N, QoS_Nodes (Current_Entity)); Set_Distributed_Application (N, Current_Entity); return N; end Map_QoS_Node; ------------------ -- Map_QoS_Unit -- ------------------ function Map_QoS_Unit (E : node_id; F : node_id := No_Node) return node_id is U : node_id; L : list_id; P : node_id; N : node_id; Ada_Name : name_id; begin pragma assert (Is_Namespace (E) or else Is_Process (E)); U := New_Node (k_qos_unit, Identifier (E)); L := New_List (k_packages); Set_Packages (U, L); if Is_Process (E) then Ada_Name := To_Ada_Name (AAN.Display_Name (AAN.Identifier (AAN.Parent_Subcomponent (E)))); -- Main suprogram P := Make_Main_Subprogram_Implementation (Make_Defining_Identifier (Ada_Name)); Set_Distributed_Application_Unit (P, U); Set_Main_Subprogram (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Main (Identifier (E), P); -- 'Helpers' package N := Defining_Identifier (RU (ru_helpers, False)); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Helpers_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Helpers (Identifier (E), P); -- 'Servants' package N := Defining_Identifier (RU (ru_servants, False)); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Servants_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Servants (Identifier (E), P); -- 'Setup' package N := Defining_Identifier (RU (ru_arao_setup_application, False)); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Setup_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Setup (Identifier (E), P); -- 'PolyORB.Parameters.Partition' package N := Defining_Identifier (RU (ru_polyorb_parameters_partition, False)); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Parameters_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Parameters (Identifier (E), P); -- 'ARAO.Object_Adapter' package N := Defining_Identifier (RU (ru_arao_object_adapter, False)); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Obj_Adapters_Package (U, P); Append_Node_To_List (P, L); Bind_AADL_To_Obj_Adapters (Identifier (E), P); elsif Is_Namespace (E) then -- 'Partition.XXX' package N := Map_Ada_Namespace_Defining_Identifier (E, "Partition"); P := Make_Package_Declaration (N); Set_Distributed_Application_Unit (P, U); Set_Namespaces_Package (U, P); Append_Node_To_List (P, L); -- We generate a Partition.XXX package per Namespace and -- Process. So the binding must use the namespace and -- process nodes (E and F). Bind_AADL_To_Namespaces (Bind_Two_Nodes (E, F), P); Bind_Ada_Identifier_To_Package (N, P); -- Set also the Main_Subprogram node to know to which -- nodebelongs this mapped unit. Set_Main_Subprogram (U, Main_Node (Backend_Node (Identifier (F)))); end if; -- Append the Unit to the units list of the current Ada -- partition. The top of the entity stack is necessarily an Ada -- partition node Append_Node_To_List (U, Units (Current_Entity)); ADN.Set_Entity (U, Current_Entity); return U; end Map_QoS_Unit; -------------------------------- -- Map_TC_Variable_Identifier -- -------------------------------- function Map_TC_Variable_Identifier (E : node_id) return node_id is Full_Name : name_id; begin pragma assert (Utils.Is_Data (E)); Full_Name := To_Ada_Name (Display_Name (Identifier (E))); Set_Str_To_Name_Buffer ("TC_"); Get_Name_String_And_Append (Full_Name); return Make_Defining_Identifier (Name_Find); end Map_TC_Variable_Identifier; --------------------------------- -- Map_Record_Field_Identifier -- --------------------------------- function Map_Record_Field_Identifier (S : node_id) return node_id is begin pragma assert (Kind (S) = k_subcomponent_instance and then Utils.Is_Data (Corresponding_Instance (S))); Set_Str_To_Name_Buffer ("Result_"); Get_Name_String_And_Append (Display_Name (Identifier (S))); return Make_Defining_Identifier (Name_Find); end Map_Record_Field_Identifier; ------------------------------- -- Map_Initialize_Identifier -- ------------------------------- function Map_Initialize_Identifier (E : node_id) return node_id is Type_Name : name_id; begin pragma assert (Utils.Is_Data (E)); Type_Name := To_Ada_Name (Display_Name (Identifier (E))); Set_Str_To_Name_Buffer ("Initialize_"); Get_Name_String_And_Append (Type_Name); return Make_Defining_Identifier (Name_Find); end Map_Initialize_Identifier; ------------------------------------- -- Map_Initialized_Flag_Identifier -- ------------------------------------- function Map_Initialized_Flag_Identifier (E : node_id) return node_id is Type_Name : name_id; begin pragma assert (Utils.Is_Data (E)); Type_Name := To_Ada_Name (Display_Name (Identifier (E))); Get_Name_String (Type_Name); Add_Str_To_Name_Buffer ("_Initialized"); return Make_Defining_Identifier (Name_Find); end Map_Initialized_Flag_Identifier; ------------------------------------------ -- Map_Package_Instantiation_Designator -- ------------------------------------------ function Map_Package_Instantiation_Designator (E : node_id) return node_id is N : node_id; begin pragma assert (Utils.Is_Data (E)); N := Map_Ada_Data_Type_Designator (E); Get_Name_String (ADN.Name (ADN.Defining_Identifier (N))); Add_Str_To_Name_Buffer ("_PKG"); ADN.Set_Name (ADN.Defining_Identifier (N), Name_Find); return N; end Map_Package_Instantiation_Designator; -------------------- -- Map_Dependency -- -------------------- function Map_Dependency (Dep : node_id) return node_id is function "=" (Name : name_id; Node : node_id) return Boolean; function Is_Internal_Unit (Unit : node_id) return Boolean; --------- -- "=" -- --------- function "=" (Name : name_id; Node : node_id) return Boolean is begin return Name = Fully_Qualified_Name (Node); end "="; ---------------------- -- Is_Internal_Unit -- ---------------------- function Is_Internal_Unit (Unit : node_id) return Boolean is N : node_id := Unit; begin if ADN.Kind (N) = k_designator then N := Defining_Identifier (N); end if; return ADN.Kind (Corresponding_Node (N)) = k_package_instantiation; end Is_Internal_Unit; Dep_Name : name_id; V : value_id; N : node_id; begin if Is_Internal_Unit (Dep) then return No_Node; end if; Dep_Name := Fully_Qualified_Name (Dep); -- Second case : We lower the case of these entities -- * ARAO.Setup.OA.Multithreaded if Dep_Name = RU (ru_arao_setup_oa_multithreaded, False) then Get_Name_String (Dep_Name); GNAT.Case_Util.To_Lower (Name_Buffer (1 .. Name_Len)); Dep_Name := Name_Find; -- Third case : Some PolyORB units have a customized -- initialization name elsif Dep_Name = RU (ru_polyorb_setup_oa_basic_rt_poa, False) then Set_Str_To_Name_Buffer ("rt_poa"); Dep_Name := Name_Find; elsif Dep_Name = RU (ru_polyorb_any_initialization, False) then Set_Str_To_Name_Buffer ("any"); Dep_Name := Name_Find; end if; V := New_String_Value (Dep_Name); N := Make_Literal (V); return N; end Map_Dependency; -------------------------------- -- Map_Object_Type_Identifier -- -------------------------------- function Map_Object_Type_Identifier (E : node_id) return node_id is begin pragma assert (Is_Thread (E)); Get_Name_String (AAU.Compute_Full_Name_Of_Instance (Parent_Subcomponent (E), True, False)); Add_Str_To_Name_Buffer ("_Object"); return Make_Defining_Identifier (Name_Find); end Map_Object_Type_Identifier; ------------------------------ -- Map_Reference_Identifier -- ------------------------------ function Map_Reference_Identifier (E : node_id) return node_id is begin pragma assert (Is_Thread (E) or else AAN.Kind (E) = k_port_spec_instance); if Is_Thread (E) then Get_Name_String (AAU.Compute_Full_Name_Of_Instance (Parent_Subcomponent (E), True, False)); else Get_Name_String (AAU.Compute_Full_Name_Of_Instance (E, True, False)); end if; Add_Str_To_Name_Buffer ("_Ref"); return Make_Defining_Identifier (Name_Find); end Map_Reference_Identifier; -------------------------------------- -- Map_Thread_Controller_Identifier -- -------------------------------------- function Map_Thread_Controller_Identifier (E : node_id) return node_id is begin pragma assert (Is_Thread (E)); Get_Name_String (AAU.Compute_Full_Name_Of_Instance (Parent_Subcomponent (E), True, False)); Add_Str_To_Name_Buffer ("_Controller"); return Make_Defining_Identifier (Name_Find); end Map_Thread_Controller_Identifier; ------------------ -- Map_Ada_Time -- ------------------ function Map_Ada_Time (T : time_type) return node_id is Time : unsigned_long_long; S : node_id; begin case T.U is when picosecond => -- If we can convert it into nanosecond, we are -- OK. Otherwise this is an error because Ada.Real_Time -- does not support picoseconds if T.T mod 1000 = 0 then Time := T.T / 1000; S := RE (re_nanoseconds); else return No_Node; end if; when nanosecond => Time := T.T; S := RE (re_nanoseconds); when microsecond => Time := T.T; S := RE (re_microseconds); when millisecond => Time := T.T; S := RE (re_milliseconds); when second => Time := T.T; S := RE (re_seconds); when minute => Time := T.T; S := RE (re_minutes); when hour => -- Convert it into minutes Time := T.T * 60; S := RE (re_minutes); end case; return Make_Subprogram_Call (S, Make_List_Id (Make_Literal (New_Integer_Value (Time, 1, 10)))); end Map_Ada_Time; ---------------------- -- Map_Ada_Priority -- ---------------------- function Map_Ada_Priority (P : unsigned_long_long) return node_id is AADL_Delta : constant unsigned_long_long := Get_Max_Priority - Get_Min_Priority; System_PF : constant node_id := Make_Attribute_Designator (RE (re_priority), a_first); System_PL : constant node_id := Make_Attribute_Designator (RE (re_priority), a_last); Result : node_id; begin -- ------------------------------------------------------- -- ^ ^ ^ -- Min_AADL X_AADL Max_AADL -- ------------------------------------------------------- -- ^ ^ ^ -- Min_Ada X_Ada Max_Ada -- X_Ada = Min_Ada + (X_AADL - Min_AADL) * (Max_Ada - Min_Ada) -- ________________________________________ -- (Max_AADL - Min_AADL) -- (X_AADL - Min_AADL) Result := Make_Expression (Make_Literal (New_Integer_Value (P, 1, 10)), op_minus, Make_Literal (New_Integer_Value (Get_Min_Priority, 1, 10))); -- ... * (Max_Ada - Min_Ada) Result := Make_Expression (Result, op_asterisk, Make_Expression (System_PL, op_minus, System_PF)); -- ... / (Max_AADL - Min_AADL) Result := Make_Expression (Result, op_slash, Make_Literal (New_Integer_Value (AADL_Delta, 1, 10))); -- Min_Ada + ... Result := Make_Expression (System_PF, op_plus, Result); return Result; end Map_Ada_Priority; ------------------------------------ -- Map_Buffer_Instance_Identifier -- ------------------------------------ function Map_Buffer_Instance_Identifier (P : node_id) return node_id is Port_Name : name_id; Thread_Name : name_id; begin pragma assert (Kind (P) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (P))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (P))))); Get_Name_String (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); Add_Str_To_Name_Buffer ("_Buffer"); return Make_Defining_Identifier (Name_Find); end Map_Buffer_Instance_Identifier; ----------------------------- -- Map_Variable_Identifier -- ----------------------------- function Map_Variable_Identifier (P : node_id) return node_id is Port_Name : name_id; Thread_Name : name_id; begin pragma assert (Kind (P) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (P))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (P))))); Get_Name_String (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); Add_Str_To_Name_Buffer ("_Var"); return Make_Defining_Identifier (Name_Find); end Map_Variable_Identifier; ---------------------------- -- Map_Package_Identifier -- ---------------------------- function Map_Package_Identifier (E : node_id) return node_id is Port_Name : name_id; Thread_Name : name_id; begin pragma assert (Utils.Is_Data (E) or else Kind (E) = k_port_spec_instance); if Utils.Is_Data (E) then Get_Name_String (To_Ada_Name (Display_Name (Identifier (E)))); else Port_Name := To_Ada_Name (Display_Name (Identifier (E))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Get_Name_String (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); end if; Add_Str_To_Name_Buffer ("_Pkg"); return Make_Defining_Identifier (Name_Find); end Map_Package_Identifier; -------------------------- -- Map_Mutex_Identifier -- -------------------------- function Map_Mutex_Identifier (E : node_id) return node_id is Thread_Name : name_id; begin pragma assert (Is_Thread (E)); -- The mutex name is mapped from the subcomponent name to avoid -- name clashing. Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (E)))); Get_Name_String (Thread_Name); Add_Str_To_Name_Buffer ("_Mutex"); return Make_Defining_Identifier (Name_Find); end Map_Mutex_Identifier; ---------------------------------- -- Map_Port_Argument_Identifier -- ---------------------------------- function Map_Port_Argument_Identifier (E : node_id) return node_id is Port_Name : name_id; begin pragma assert (Kind (E) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (E))); Get_Name_String (Port_Name); Add_Str_To_Name_Buffer ("_Arg"); return Make_Defining_Identifier (Name_Find); end Map_Port_Argument_Identifier; --------------------------------- -- Map_Port_Boolean_Identifier -- --------------------------------- function Map_Port_Boolean_Identifier (E : node_id) return node_id is Port_Name : name_id; begin pragma assert (Kind (E) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (E))); Get_Name_String (Port_Name); Add_Str_To_Name_Buffer ("_Present"); return Make_Defining_Identifier (Name_Find); end Map_Port_Boolean_Identifier; ----------------------------------- -- Map_Get_Subprogram_Identifier -- ----------------------------------- function Map_Get_Subprogram_Identifier (E : node_id) return node_id is Entity_Name : name_id; Thread_Name : name_id; begin pragma assert (Utils.Is_Data (E) or else Kind (E) = k_port_spec_instance); if Utils.Is_Data (E) then Entity_Name := AAU.Compute_Full_Name_Of_Instance (E, True, False); else Entity_Name := To_Ada_Name (Display_Name (Identifier (E))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); end if; Set_Str_To_Name_Buffer ("Get_"); if Kind (E) = k_port_spec_instance then Get_Name_String_And_Append (Thread_Name); Add_Char_To_Name_Buffer ('_'); end if; Get_Name_String_And_Append (Entity_Name); return Make_Defining_Identifier (Name_Find); end Map_Get_Subprogram_Identifier; ----------------------------------- -- Map_Put_Subprogram_Identifier -- ----------------------------------- function Map_Put_Subprogram_Identifier (E : node_id) return node_id is Port_Name : name_id; Thread_Name : name_id; begin pragma assert (Kind (E) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (E))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Set_Str_To_Name_Buffer ("Put_"); Get_Name_String_And_Append (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); return Make_Defining_Identifier (Name_Find); end Map_Put_Subprogram_Identifier; ----------------------------------------- -- Map_Push_Back_Subprogram_Identifier -- ----------------------------------------- function Map_Push_Back_Subprogram_Identifier (E : node_id) return node_id is Port_Name : name_id; Thread_Name : name_id; begin pragma assert (Kind (E) = k_port_spec_instance); Port_Name := To_Ada_Name (Display_Name (Identifier (E))); Thread_Name := To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Set_Str_To_Name_Buffer ("Push_Back_"); Get_Name_String_And_Append (Thread_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Port_Name); return Make_Defining_Identifier (Name_Find); end Map_Push_Back_Subprogram_Identifier; ----------------------------------- -- Package_Binding_Internal_Name -- ----------------------------------- function Package_Binding_Internal_Name (I : node_id) return name_id is begin if No (I) then return No_Name; end if; pragma assert (Kind (I) = k_defining_identifier); if ADN.Name (I) = No_Name then return No_Name; end if; Set_Str_To_Name_Buffer ("%package%id%binding%"); Get_Name_String_And_Append (ADN.Name (I)); return Name_Find; end Package_Binding_Internal_Name; ------------------------------------ -- Bind_Ada_Identifier_To_Package -- ------------------------------------ procedure Bind_Ada_Identifier_To_Package (I : node_id; P : node_id) is N : constant name_id := Package_Binding_Internal_Name (I); begin if N = No_Name then raise Program_Error with "Bind_Ada_Identifier_To_Package:" & " Try to bind a nul node"; end if; Set_Name_Table_Info (N, nat (P)); end Bind_Ada_Identifier_To_Package; ----------------------- -- Get_Bound_Package -- ----------------------- function Get_Bound_Package (I : node_id) return node_id is N : constant name_id := Package_Binding_Internal_Name (I); begin if N = No_Name then return No_Node; end if; return node_id (Get_Name_Table_Info (N)); end Get_Bound_Package; ------------------------ -- Bind_AADL_To_Setup -- ------------------------ procedure Bind_AADL_To_Setup (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Setup_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Setup; ----------------------------- -- Bind_AADL_To_Parameters -- ----------------------------- procedure Bind_AADL_To_Parameters (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Parameters_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Parameters; ------------------------------- -- Bind_AADL_To_Obj_Adapters -- ------------------------------- procedure Bind_AADL_To_Obj_Adapters (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Obj_Adapters_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Obj_Adapters; -------------------------- -- Bind_AADL_To_Helpers -- -------------------------- procedure Bind_AADL_To_Helpers (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Helpers_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Helpers; ----------------------- -- Bind_AADL_To_Main -- ----------------------- procedure Bind_AADL_To_Main (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Main_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Main; --------------------------- -- Bind_AADL_To_Servants -- --------------------------- procedure Bind_AADL_To_Servants (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Servants_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Servants; ----------------------------- -- Bind_AADL_To_Namespaces -- ----------------------------- procedure Bind_AADL_To_Namespaces (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Namespaces_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Namespaces; --------------------------- -- Bind_AADL_To_TypeCode -- --------------------------- procedure Bind_AADL_To_TypeCode (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_TypeCode_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_TypeCode; ---------------------------------- -- Bind_AADL_To_Execute_Servant -- ---------------------------------- procedure Bind_AADL_To_Execute_Servant (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Execute_Servant_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Execute_Servant; --------------------------- -- Bind_AADL_To_From_Any -- --------------------------- procedure Bind_AADL_To_From_Any (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_From_Any_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_From_Any; ----------------------------- -- Bind_AADL_To_Initialize -- ----------------------------- procedure Bind_AADL_To_Initialize (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Initialize_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Initialize; ---------------------------- -- Bind_AADL_To_Reference -- ---------------------------- procedure Bind_AADL_To_Reference (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Reference_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Reference; ----------------------------- -- Bind_AADL_To_Subprogram -- ----------------------------- procedure Bind_AADL_To_Subprogram (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Subprogram_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Subprogram; ------------------------------------- -- Bind_AADL_To_Feature_Subprogram -- ------------------------------------- procedure Bind_AADL_To_Feature_Subprogram (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_hi_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Feature_Subprogram_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Feature_Subprogram; ---------------------- -- Bind_AADL_To_Set -- ---------------------- procedure Bind_AADL_To_Set (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Set_Node (N, A); end Bind_AADL_To_Set; ------------------------ -- Bind_AADL_To_Build -- ------------------------ procedure Bind_AADL_To_Build (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Build_Node (N, A); end Bind_AADL_To_Build; ------------------------- -- Bind_AADL_To_To_Any -- ------------------------- procedure Bind_AADL_To_To_Any (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_To_Any_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_To_Any; ------------------------------------ -- Bind_AADL_To_Thread_Controller -- ------------------------------------ procedure Bind_AADL_To_Thread_Controller (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Thread_Controller_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Thread_Controller; ---------------------------------- -- Bind_AADL_To_Type_Definition -- ---------------------------------- procedure Bind_AADL_To_Type_Definition (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Type_Definition_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Type_Definition; -------------------------- -- Bind_AADL_To_Package -- -------------------------- procedure Bind_AADL_To_Package (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Package_Node (N, A); end Bind_AADL_To_Package; ---------------------- -- Bind_AADL_To_Put -- ---------------------- procedure Bind_AADL_To_Put (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Put_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Put; ---------------------------- -- Bind_AADL_To_Push_Back -- ---------------------------- procedure Bind_AADL_To_Push_Back (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Push_Back_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Push_Back; ---------------------- -- Bind_AADL_To_Get -- ---------------------- procedure Bind_AADL_To_Get (G : node_id; A : node_id) is N : node_id; begin N := AAN.Backend_Node (G); if No (N) then N := New_Node (ADN.k_qos_tree_bindings); AAN.Set_Backend_Node (G, N); end if; ADN.Set_Get_Node (N, A); ADN.Set_Frontend_Node (A, G); end Bind_AADL_To_Get; ------------------------------- -- Get_Servant_Internal_Name -- ------------------------------- function Get_Servant_Internal_Name (Entity : node_id) return name_id is begin pragma assert (Is_Process (Entity) or else Is_Thread (Entity)); if Is_Process (Entity) then Set_Str_To_Name_Buffer ("%process%servants%"); else Set_Str_To_Name_Buffer ("%thread%servant%"); end if; Add_Nat_To_Name_Buffer (nat (Entity)); return Name_Find; end Get_Servant_Internal_Name; --------------------------- -- Compute_Servant_Index -- --------------------------- procedure Compute_Servant_Index (T : node_id) is T_Internal_Name : constant name_id := Get_Servant_Internal_Name (T); Parent_Process : constant node_id := Parent_Component (Parent_Subcomponent (T)); P_Internal_Name : constant name_id := Get_Servant_Internal_Name (Parent_Process); Info : int; begin -- The Name_Table_Infos are initialized to 0, which is exactly -- what we want. Info := Get_Name_Table_Info (P_Internal_Name) + 1; Set_Name_Table_Info (T_Internal_Name, Info); -- Update the info for next threads Set_Name_Table_Info (P_Internal_Name, Info); end Compute_Servant_Index; ----------------------- -- Get_Servant_Index -- ----------------------- function Get_Servant_Index (T : node_id) return nat is T_Internal_Name : constant name_id := Get_Servant_Internal_Name (T); Info : constant int := Get_Name_Table_Info (T_Internal_Name); begin return Info; end Get_Servant_Index; end Ocarina.Generators.PO_QoS_Ada.Mapping;