--------------------------------------------- ----------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-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.OS_Lib; with GNAT.Directory_Operations; with GNAT.Table; with Namet; with Locations; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components.Connections; with Ocarina.Generators.Messages; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.Utils is package AAU renames Ocarina.Nutils; package ADN renames Ocarina.Generators.Ada_Tree.Nodes; package ADU renames Ocarina.Generators.Ada_Tree.Nutils; package ADV renames Ocarina.Generators.Ada_Values; use GNAT.OS_Lib; use GNAT.Directory_Operations; use Namet; use Locations; use Ocarina.Nodes; use Ocarina.Nutils; use Ocarina.Entities; use Ocarina.Entities.Components; use Ocarina.Entities.Components.Connections; use Ocarina.Generators.Messages; use Ocarina.Generators.Ada_Tree.Nutils; -- The entered directories stack package Directories_Stack is new GNAT.Table (name_id, int, 1, 5, 10); function Get_Handling_Internal_Name (E : node_id; Comparison : comparison_kind; Handling : handling_kind) return name_id; -- Code factorisation between Set_Handling and Get_Handling. This -- fucntion computes an internal name used to store the handling -- information. function Map_Ada_Subprogram_Status_Name (S : node_id) return name_id; -- Maps an name for the record type corresponding to a hybrid -- subprogram. function Map_Ada_Call_Seq_Access_Name (S : node_id) return name_id; -- Maps an name for the subprogram access type corresponding to a -- hybrid subprogram. function Map_Ada_Call_Seq_Subprogram_Name (Spg : node_id; Seq : node_id) return name_id; -- Maps an name for the subprogra corresponding to a hybrid -- subprogram call sequence. type repository_entry is record E : node_id; Comparison : comparison_kind; Handling : handling_kind; A : node_id; end record; -- One entry of the internal handling repository Recording_Requested : Boolean := False; package Handling_Repository is new GNAT.Table (repository_entry, int, 1, 5, 10); -- The internal handling repository procedure May_Be_Append_Handling_Entry (E : node_id; Comparison : comparison_kind; Handling : handling_kind; A : node_id); -- Add a new entry corresponding to the given parameters to the -- internal handling repository. The addition is only done in case -- the user requested explicitely the recording of handling function Bind_Transport_API_Internal_Name (P : node_id) return name_id; -- For code factorization puspose ---------------------- -- Create_Directory -- ---------------------- procedure Create_Directory (Dir_Full_Name : name_id) is Dir_Full_String : constant String := Get_Name_String (Dir_Full_Name); begin if Is_Regular_File (Dir_Full_String) or else Is_Symbolic_Link (Dir_Full_String) then Display_Error ("Cannot create " & Dir_Full_String & " because there is a file with the same name", Fatal => True); return; end if; if Is_Directory (Dir_Full_String) then Display_Error (Dir_Full_String & " already exists", Fatal => False, Warning => True); return; end if; -- The directory name does not clash with anything, create it Make_Dir (Dir_Full_String); end Create_Directory; --------------------- -- Enter_Directory -- --------------------- procedure Enter_Directory (Dirname : name_id) is use Directories_Stack; Current_Directory : constant name_id := Get_String_Name (Get_Current_Dir); begin Increment_Last; Table (Last) := Current_Directory; Display_Debug_Message ("Left : " & Get_Name_String (Current_Directory)); Change_Dir (Get_Name_String (Dirname)); Display_Debug_Message ("Entered : " & Get_Name_String (Dirname)); end Enter_Directory; --------------------- -- Leave_Directory -- --------------------- procedure Leave_Directory is use Directories_Stack; Last_Directory : constant name_id := Table (Last); begin Decrement_Last; Display_Debug_Message ("Left : " & Get_Current_Dir); Change_Dir (Get_Name_String (Last_Directory)); Display_Debug_Message ("Entered : " & Get_Name_String (Last_Directory)); end Leave_Directory; ----------------------------- -- Add_Directory_Separator -- ----------------------------- function Add_Directory_Separator (Path : name_id) return name_id is begin Get_Name_String (Path); if Name_Buffer (Name_Len) /= Directory_Separator then Add_Char_To_Name_Buffer (Directory_Separator); end if; return Name_Find; end Add_Directory_Separator; -------------------------------- -- Remove_Directory_Separator -- -------------------------------- function Remove_Directory_Separator (Path : name_id) return name_id is begin Get_Name_String (Path); if Name_Buffer (Name_Len) = Directory_Separator then Name_Len := Name_Len - 1; end if; return Name_Find; end Remove_Directory_Separator; ---------------------------------- -- May_Be_Append_Handling_Entry -- ---------------------------------- procedure May_Be_Append_Handling_Entry (E : node_id; Comparison : comparison_kind; Handling : handling_kind; A : node_id) is package HR renames Handling_Repository; The_Entry : constant repository_entry := repository_entry' (E => E, Comparison => Comparison, Handling => Handling, A => A); begin if Recording_Requested then HR.Increment_Last; HR.Table (HR.Last) := The_Entry; end if; end May_Be_Append_Handling_Entry; ------------------------------- -- Start_Recording_Handlings -- ------------------------------- procedure Start_Recording_Handlings is begin if Recording_Requested then raise Program_Error with "Consecutive calls to Start_Recording_Handlings are forbidden"; else Recording_Requested := True; end if; end Start_Recording_Handlings; ------------------------------ -- Stop_Recording_Handlings -- ------------------------------ procedure Stop_Recording_Handlings is begin Recording_Requested := False; end Stop_Recording_Handlings; --------------------- -- Reset_Handlings -- --------------------- procedure Reset_Handlings is package HR renames Handling_Repository; Index : int := HR.First; The_Entry : repository_entry; begin -- Disable the user handling request. It is important to do -- this at the beginning to avoid adding new entries when -- resetting. Recording_Requested := False; while Index <= HR.Last loop The_Entry := HR.Table (Index); -- Reset the handling information Set_Handling (The_Entry.E, The_Entry.Comparison, The_Entry.Handling, No_Node); Index := Index + 1; end loop; -- Deallocate and reinitialize the repository HR.Free; HR.Init; end Reset_Handlings; --------------------- -- Get_String_Name -- --------------------- function Get_String_Name (The_String : String) return name_id is pragma assert (The_String'length > 0); Result : name_id; begin Set_Str_To_Name_Buffer (The_String); Result := Name_Find; return Result; end Get_String_Name; -------------------- -- Normalize_Name -- -------------------- function Normalize_Name (Name : name_id) return name_id is Normalized_Name : name_id; begin -- FIXME: The algorithm does not ensure a bijection between -- the input and the output. It should be improved. if Name = No_Name then Normalized_Name := Name; else declare Initial_Name : constant String := Get_Name_String (Name); begin Name_Len := 0; for Index in Initial_Name'first .. Initial_Name'last loop if Initial_Name (Index) = '.' then Add_Char_To_Name_Buffer ('_'); elsif Initial_Name (Index) = '-' then Add_Char_To_Name_Buffer ('_'); else Add_Char_To_Name_Buffer (Initial_Name (Index)); end if; end loop; Normalized_Name := Name_Find; end; end if; return Normalized_Name; end Normalize_Name; ------------- -- Is_Data -- ------------- function Is_Data (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_data; else return False; end if; end Is_Data; ------------------- -- Is_Subprogram -- ------------------- function Is_Subprogram (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_subprogram; else return False; end if; end Is_Subprogram; ---------------- -- Is_Process -- ---------------- function Is_Process (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_process; else return False; end if; end Is_Process; --------------- -- Is_Thread -- --------------- function Is_Thread (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_thread; else return False; end if; end Is_Thread; --------------- -- Is_System -- --------------- function Is_System (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_system; else return False; end if; end Is_System; ------------------ -- Is_Namespace -- ------------------ function Is_Namespace (N : node_id) return Boolean is begin return Kind (N) = k_namespace_instance; end Is_Namespace; ------------------ -- Is_Processor -- ------------------ function Is_Processor (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_processor; else return False; end if; end Is_Processor; ------------ -- Is_Bus -- ------------ function Is_Bus (C : node_id) return Boolean is begin if Kind (C) = k_component_instance then return Get_Category_Of_Component (C) = cc_bus; else return False; end if; end Is_Bus; ----------------------- -- Has_In_Parameters -- ----------------------- function Has_In_Parameters (E : node_id) return Boolean is F : node_id; begin if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_parameter_instance and then Is_In (F) then return True; end if; F := Next_Node (F); end loop; end if; return False; end Has_In_Parameters; ------------------------ -- Has_Out_Parameters -- ------------------------ function Has_Out_Parameters (E : node_id) return Boolean is F : node_id; begin if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_parameter_instance and then Is_Out (F) then return True; end if; F := Next_Node (F); end loop; end if; return False; end Has_Out_Parameters; ------------------ -- Has_In_Ports -- ------------------ function Has_In_Ports (E : node_id) return Boolean is F : node_id; begin if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_In (F) then return True; end if; F := Next_Node (F); end loop; end if; return False; end Has_In_Ports; ------------------- -- Has_Out_Ports -- ------------------- function Has_Out_Ports (E : node_id) return Boolean is F : node_id; begin if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = k_port_spec_instance and then Is_Out (F) then return True; end if; F := Next_Node (F); end loop; end if; return False; end Has_Out_Ports; --------------- -- Has_Ports -- --------------- function Has_Ports (E : node_id) return Boolean is F : node_id; begin 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 return True; end if; F := Next_Node (F); end loop; end if; return False; end Has_Ports; --------------- -- Has_Modes -- --------------- function Has_Modes (E : node_id) return Boolean is begin pragma assert (Kind (E) = k_component_instance); return not AAU.Is_Empty (Modes (E)); end Has_Modes; ---------------------- -- Get_Source_Ports -- ---------------------- function Get_Source_Ports (P : node_id) return list_id is Result : constant list_id := New_List (k_list_id, No_Location); S : node_id; begin S := First_Node (Sources (P)); while Present (S) loop if Kind (Item (S)) = k_port_spec_instance and then Is_Thread (Parent_Component (Item (S))) then -- We reached our end point, append it to the result list AAU.Append_Node_To_List (Make_Node_Container (Item (S)), Result); elsif Kind (Item (S)) = k_port_spec_instance and then Is_Process (Parent_Component (Item (S))) then -- Fetch recursively all the sources of S AAU.Append_Node_To_List (First_Node (Get_Source_Ports (Item (S))), Result); else Display_Located_Error (Loc (P), "This port has a source of a non supported kind", Fatal => True); end if; S := Next_Node (S); end loop; return Result; end Get_Source_Ports; --------------------------- -- Get_Destination_Ports -- --------------------------- function Get_Destination_Ports (P : node_id) return list_id is Result : constant list_id := New_List (k_list_id, No_Location); D : node_id; begin D := First_Node (Destinations (P)); while Present (D) loop if Kind (Item (D)) = k_port_spec_instance and then Is_Thread (Parent_Component (Item (D))) then -- We reached our end point, append it to the result list AAU.Append_Node_To_List (Make_Node_Container (Item (D)), Result); elsif Kind (Item (D)) = k_port_spec_instance and then Is_Process (Parent_Component (Item (D))) then -- Fetch recursively all the destinations of D AAU.Append_Node_To_List (First_Node (Get_Destination_Ports (Item (D))), Result); else Display_Located_Error (Loc (P), "This port has a destination of a non supported kind", Fatal => True); end if; D := Next_Node (D); end loop; return Result; end Get_Destination_Ports; ---------------------- -- Get_Actual_Owner -- ---------------------- function Get_Actual_Owner (Spg_Call : node_id) return node_id is Spg : constant node_id := Corresponding_Instance (Spg_Call); Data_Component : node_id; F : node_id; begin -- If the subprogram call is not a method return No_Node if AAU.Is_Empty (Path (Spg_Call)) then return No_Node; end if; Data_Component := Item (First_Node (Path (Spg_Call))); -- Traverse all the required access of the subprogram instance -- and find the one corresponding to the its owner data -- component. if not AAU.Is_Empty (Features (Spg)) then F := First_Node (Features (Spg)); while Present (F) loop if Kind (F) = k_subcomponent_access_instance then -- FIXME: We stop at the first met feature that -- corresponds to our criteria. -- The corresponding declaration of Data_Component is -- always a component type and not a component -- implementation. However the type of the feature F -- may be a component type as well as a component -- implementation. We test both cases. declare Dcl_Data_Component : constant node_id := Corresponding_Declaration (Data_Component); Dcl_F : constant node_id := Corresponding_Declaration (Corresponding_Instance (F)); begin exit when (Kind (Dcl_F) = k_component_type and then Dcl_F = Dcl_Data_Component) or else (Kind (Dcl_F) = k_component_implementation and then Corresponding_Entity (Component_Type_Identifier (Dcl_F)) = Dcl_Data_Component); end; end if; F := Next_Node (F); end loop; end if; -- If no feature matched, raise an error if AAU.Is_Empty (Features (Spg)) or else No (F) then Display_Located_Error (Loc (Spg), "Feature subprogram has not access to its owner component", Fatal => True); end if; return Get_Subcomponent_Access_Source (F); end Get_Actual_Owner; --------------------------- -- Get_Container_Process -- --------------------------- function Get_Container_Process (E : node_id) return node_id is begin case Kind (E) is when k_call_instance => return Get_Container_Process (Parent_Sequence (E)); when k_call_sequence_instance | k_subcomponent_instance => return Get_Container_Process (Parent_Component (E)); when others => if Is_Thread (E) or else Is_Subprogram (E) then return Get_Container_Process (Parent_Subcomponent (E)); elsif Is_Process (E) then return Parent_Subcomponent (E); else raise Program_Error with "Wrong node kind in " & "Get_Container_Process: " & Kind (E)'img; end if; end case; end Get_Container_Process; -------------------------- -- Get_Container_Thread -- -------------------------- function Get_Container_Thread (E : node_id) return node_id is begin case Kind (E) is when k_call_instance => return Get_Container_Thread (Parent_Sequence (E)); when k_call_sequence_instance => return Parent_Component (E); when others => if Is_Subprogram (E) then return Get_Container_Thread (Parent_Subcomponent (E)); else raise Program_Error with "Wrong node kind in " & "Get_Container_Thread: " & Kind (E)'img; end if; end case; end Get_Container_Thread; -------------------------------- -- Get_Handling_Internal_Name -- -------------------------------- function Get_Handling_Internal_Name (E : node_id; Comparison : comparison_kind; Handling : handling_kind) return name_id is begin case Comparison is when by_name => Get_Name_String (Compute_Full_Name_Of_Instance (E)); when by_node => Set_Nat_To_Name_Buffer (nat (E)); end case; Add_Str_To_Name_Buffer ("%Handling%" & Handling'img); return Name_Find; end Get_Handling_Internal_Name; ------------------ -- Set_Handling -- ------------------ procedure Set_Handling (E : node_id; Comparison : comparison_kind; Handling : handling_kind; A : node_id) is Internal_Name : constant name_id := Get_Handling_Internal_Name (E, Comparison, Handling); begin Set_Name_Table_Info (Internal_Name, nat (A)); May_Be_Append_Handling_Entry (E, Comparison, Handling, A); end Set_Handling; ------------------ -- Get_Handling -- ------------------ function Get_Handling (E : node_id; Comparison : comparison_kind; Handling : handling_kind) return node_id is Internal_Name : constant name_id := Get_Handling_Internal_Name (E, Comparison, Handling); begin return node_id (Get_Name_Table_Info (Internal_Name)); end Get_Handling; -------------------- -- Bind_Two_Nodes -- -------------------- function Bind_Two_Nodes (N_1 : node_id; N_2 : node_id) return node_id is function Get_Binding_Internal_Name (N_1 : node_id; N_2 : node_id) return name_id; -- Return an internam name id useful for the binding ------------------------------- -- Get_Binding_Internal_Name -- ------------------------------- function Get_Binding_Internal_Name (N_1 : node_id; N_2 : node_id) return name_id is begin Set_Nat_To_Name_Buffer (nat (N_1)); Add_Str_To_Name_Buffer ("%Binding%"); Add_Nat_To_Name_Buffer (nat (N_2)); return Name_Find; end Get_Binding_Internal_Name; I_Name : constant name_id := Get_Binding_Internal_Name (N_1, N_2); N : node_id; begin -- If the Bind_Two_Nodes has already been called on N_1 and -- N_1, return the result of the first call. if Get_Name_Table_Info (I_Name) /= 0 then return node_id (Get_Name_Table_Info (I_Name)); end if; -- Otherwise, create a new binding node N := Make_Identifier (No_Location, No_Name, No_Name, No_Node); Set_Name_Table_Info (I_Name, int (N)); return N; end Bind_Two_Nodes; -------------------------------------- -- Bind_Transport_API_Internal_Name -- -------------------------------------- function Bind_Transport_API_Internal_Name (P : node_id) return name_id is begin pragma assert (Is_Process (P)); Set_Nat_To_Name_Buffer (nat (P)); Add_Str_To_Name_Buffer ("%transport%layer%binding%"); return Name_Find; end Bind_Transport_API_Internal_Name; ------------------------ -- Bind_Transport_API -- ------------------------ procedure Bind_Transport_API (P : node_id; T : supported_transport_apis) is I_Name : constant name_id := Bind_Transport_API_Internal_Name (P); begin Set_Name_Table_Byte (I_Name, supported_transport_apis'pos (T)); end Bind_Transport_API; ------------------------- -- Fetch_Transport_API -- ------------------------- function Fetch_Transport_API (P : node_id) return supported_transport_apis is I_Name : constant name_id := Bind_Transport_API_Internal_Name (P); begin return supported_transport_apis'val (Get_Name_Table_Byte (I_Name)); end Fetch_Transport_API; ------------------------------- -- Map_Ada_Full_Feature_Name -- ------------------------------- function Map_Ada_Full_Feature_Name (E : node_id; Suffix : Character := ASCII.NUL) return name_id is begin Get_Name_String (Compute_Full_Name_Of_Instance (Instance => E, Display_Name => True, Keep_Root_System => False)); Get_Name_String (ADU.To_Ada_Name (Name_Find)); if Suffix /= ASCII.NUL then Add_Str_To_Name_Buffer ('_' & Suffix); end if; return Name_Find; end Map_Ada_Full_Feature_Name; ---------------------------------- -- Map_Ada_Data_Type_Designator -- ---------------------------------- function Map_Ada_Data_Type_Designator (E : node_id) return node_id is begin pragma assert (Utils.Is_Data (E)); return ADU.Extract_Designator (ADN.Type_Definition_Node (Backend_Node (Identifier (E)))); end Map_Ada_Data_Type_Designator; --------------------------------- -- Map_Ada_Full_Parameter_Name -- --------------------------------- function Map_Ada_Full_Parameter_Name (Spg : node_id; P : node_id; Suffix : Character := ASCII.NUL) return name_id is begin pragma assert (Kind (P) = k_parameter_instance); if Kind (Spg) = k_component_instance and then Is_Subprogram (Spg) then Get_Name_String (Compute_Full_Name_Of_Instance (Spg, True)); elsif Kind (Spg) = k_call_instance then Get_Name_String (Display_Name (Identifier (Spg))); else raise Program_Error with "Wrong subprogram kind"; end if; Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Display_Name (Identifier (P))); -- Convert the name to a valid Ada identifier name Get_Name_String (ADU.To_Ada_Name (Name_Find)); if Suffix /= ASCII.NUL then Add_Str_To_Name_Buffer ('_' & Suffix); end if; return Name_Find; end Map_Ada_Full_Parameter_Name; ----------------------------- -- Map_Ada_Enumerator_Name -- ----------------------------- function Map_Ada_Enumerator_Name (E : node_id; Server : Boolean := False) return name_id is Ada_Name_1 : name_id; Ada_Name_2 : name_id; begin pragma assert (Is_Subprogram (E) or else Kind (E) = k_subcomponent_instance); if Is_Subprogram (E) or else Is_Process (Corresponding_Instance (E)) then -- For subprograms and processes, the enemerator name is -- mapped from the entity name. Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (E)))); Add_Str_To_Name_Buffer ("_K"); elsif Is_Thread (Corresponding_Instance (E)) then -- For threads, the enumerator name is mapped from the -- containing process name and the thread subcomponent name. -- Verifiy that the thread is a subcomponent of a process pragma assert (Is_Process (Parent_Component (E))); Ada_Name_1 := ADU.To_Ada_Name (Display_Name (Identifier (Parent_Subcomponent (Parent_Component (E))))); Ada_Name_2 := ADU.To_Ada_Name (Display_Name (Identifier (E))); Get_Name_String (Ada_Name_1); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Ada_Name_2); Add_Str_To_Name_Buffer ("_K"); else raise Program_Error with "Wrong node kind for Map_Ada_Enumerator_Name"; end if; if Server then Add_Str_To_Name_Buffer ("_Server"); end if; return Name_Find; end Map_Ada_Enumerator_Name; --------------------------------- -- Map_Ada_Defining_Identifier -- --------------------------------- function Map_Ada_Defining_Identifier (A : node_id; Suffix : Character := ASCII.NUL) return node_id is I : node_id := A; Result : node_id; begin if Kind (A) /= k_identifier then I := Identifier (A); end if; Get_Name_String (To_Ada_Name (Display_Name (I))); if Suffix /= ASCII.NUL then Add_Str_To_Name_Buffer ('_' & Suffix); end if; Result := Make_Defining_Identifier (Name_Find); return Result; end Map_Ada_Defining_Identifier; ---------------------------- -- Map_Ada_Component_Name -- ---------------------------- function Map_Ada_Component_Name (F : node_id) return name_id is begin Get_Name_String (To_Ada_Name (Display_Name (Identifier (F)))); Add_Str_To_Name_Buffer ("_DATA"); return Name_Find; end Map_Ada_Component_Name; -------------------------------------------- -- Map_Ada_Protected_Aggregate_Identifier -- -------------------------------------------- function Map_Ada_Protected_Aggregate_Identifier (S : node_id; A : node_id) return node_id is S_Name : name_id; A_Name : name_id; begin pragma assert (Kind (S) = k_subcomponent_access_instance and then Kind (A) = k_subcomponent_instance); S_Name := To_Ada_Name (Display_Name (Identifier (S))); A_Name := To_Ada_Name (Display_Name (Identifier (A))); Get_Name_String (S_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (A_Name); return Make_Defining_Identifier (Name_Find); end Map_Ada_Protected_Aggregate_Identifier; -------------------------------------- -- Map_Ada_Default_Value_Identifier -- -------------------------------------- function Map_Ada_Default_Value_Identifier (D : node_id) return node_id is I : node_id; begin if Kind (D) /= k_identifier then I := Identifier (D); end if; Get_Name_String (To_Ada_Name (Display_Name (I))); Add_Str_To_Name_Buffer ("_Default_Value"); return Make_Defining_Identifier (Name_Find); end Map_Ada_Default_Value_Identifier; ----------------------------------- -- Map_Ada_Subprogram_Identifier -- ----------------------------------- function Map_Ada_Subprogram_Identifier (E : node_id) return node_id is P_Name : name_id; N : node_id; Result : node_id; Spg_Name : name_id; begin pragma assert (Is_Thread (E) or else Is_Subprogram (E) or else Kind (E) = k_port_spec_instance); if Is_Subprogram (E) and then Get_Source_Language (E) /= language_ada_95 then Display_Error ("This is not an Ada subprogram", Fatal => True); end if; -- Get the subprogram name if Is_Subprogram (E) then Spg_Name := Get_Source_Name (E); elsif Is_Thread (E) then Spg_Name := Get_Thread_Compute_Entrypoint (E); else Spg_Name := Get_Port_Compute_Entrypoint (E); end if; -- Get the package implementation and add the 'with' clause P_Name := Unit_Name (Spg_Name); if P_Name = No_Name then Display_Error ("You must give the subprogram implementation name", Fatal => True); end if; N := Make_Designator (P_Name); ADN.Set_Corresponding_Node (ADN.Defining_Identifier (N), New_Node (ADN.k_package_specification)); Add_With_Package (N); -- Get the full implementation name Get_Name_String (Local_Name (Spg_Name)); Result := Make_Defining_Identifier (Name_Find); Set_Homogeneous_Parent_Unit_Name (Result, N); return Result; end Map_Ada_Subprogram_Identifier; ----------------------------- -- Map_Ada_Subprogram_Spec -- ----------------------------- function Map_Ada_Subprogram_Spec (S : node_id) return node_id is Profile : constant list_id := ADU.New_List (ADN.k_parameter_profile); Param : node_id; Mode : mode_id; F : node_id; N : node_id; D : node_id; Field : node_id; begin pragma assert (Is_Subprogram (S)); -- We build the parameter profile of the subprogram instance by -- adding: -- First, the parameter features mapping if not AAU.Is_Empty (Features (S)) then F := First_Node (Features (S)); while Present (F) loop if Kind (F) = k_parameter_instance then if Is_In (F) and then Is_Out (F) then Mode := mode_inout; elsif Is_Out (F) then Mode := mode_out; elsif Is_In (F) then Mode := mode_in; else Display_Located_Error (Loc (F), "Unspecified parameter mode", Fatal => True); end if; D := Corresponding_Instance (F); Param := ADU.Make_Parameter_Specification (Map_Ada_Defining_Identifier (F), Map_Ada_Data_Type_Designator (D), Mode); ADU.Append_Node_To_List (Param, Profile); end if; F := Next_Node (F); end loop; end if; -- Second, the data access mapping. The data accesses are not -- mapped in the case of pure call sequence subprogram because -- they are used only to close the access chain. if Get_Subprogram_Kind (S) /= subprogram_pure_call_sequence then if not AAU.Is_Empty (Features (S)) then F := First_Node (Features (S)); while Present (F) loop if Kind (F) = k_subcomponent_access_instance then case Get_Required_Data_Access (Corresponding_Instance (F)) is when access_read_only => Mode := mode_in; when access_write_only => Mode := mode_out; when access_read_write => Mode := mode_inout; when access_none => -- By default, we allow read/write access Mode := mode_inout; when others => Display_Located_Error (Loc (F), "Unsupported required access", Fatal => True); end case; D := Corresponding_Instance (F); case Get_Data_Type (D) is when data_integer | data_boolean | data_float | data_fixed | data_string | data_wide_string | data_character | data_wide_character | data_array => -- If the data component is a simple data -- component (not a structure), we simply add a -- parameter with the computed mode and with a -- type mapped from the data component. Param := ADU.Make_Parameter_Specification (Map_Ada_Defining_Identifier (F), Map_Ada_Data_Type_Designator (D), Mode); ADU.Append_Node_To_List (Param, Profile); when data_record | data_with_accessors => -- If the data component is a complex data -- component (which has subcomponents), we add a -- parameter with the computed mode and with a -- type mapped from each subcomponent type. Field := First_Node (Subcomponents (D)); while Present (Field) loop -- The parameter name is mapped from the -- container data component and the data -- subcomponent. Param := ADU.Make_Parameter_Specification (Map_Ada_Protected_Aggregate_Identifier (F, Field), Map_Ada_Data_Type_Designator (Corresponding_Instance (Field)), Mode); ADU.Append_Node_To_List (Param, Profile); Field := Next_Node (Field); end loop; when others => Display_Located_Error (Loc (F), "Unsupported data type", Fatal => True); end case; end if; F := Next_Node (F); end loop; end if; end if; -- Last, if the subprogram has OUT ports, we add an additional -- Status paramter. if Has_Out_Ports (S) then Param := ADU.Make_Parameter_Specification (Make_Defining_Identifier (PN (p_status)), Extract_Designator (ADN.Type_Definition_Node (Backend_Node (Identifier (S)))), mode_inout); ADU.Append_Node_To_List (Param, Profile); end if; N := ADU.Make_Subprogram_Specification (Map_Ada_Defining_Identifier (S), Profile, No_Node); -- If the program is an Opaque_C, we add the Pragma Import -- instruction in the private par of the current package if Get_Subprogram_Kind (S) = subprogram_opaque_c then declare use ADN; P : constant node_id := Make_Pragma_Statement (pragma_import, Make_List_Id (Make_Defining_Identifier (PN (p_c)), Map_Ada_Defining_Identifier (S), Make_Literal (ADV.New_String_Value (Get_Source_Name (S))))); begin -- We must ensure that we are inside the scope of a -- package spec before inserting the pragma. In fact, -- Map_Ada_Subprogram_Spec is called allso when we build -- the body of the subprogram, and we do not want to -- insert the pragma when building the body. if ADN.Kind (Current_Package) = k_package_specification then ADU.Append_Node_To_List (P, Private_Part (Current_Package)); end if; end; end if; return N; end Map_Ada_Subprogram_Spec; ----------------------------- -- Map_Ada_Subprogram_Body -- ----------------------------- function Map_Ada_Subprogram_Body (S : node_id) return node_id is Spec : constant node_id := Map_Ada_Subprogram_Spec (S); Declarations : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); Profile : list_id; N : node_id; F : node_id; Call_Seq : node_id; begin case Get_Subprogram_Kind (S) is when subprogram_empty => -- An empty AADL subprogram is mapped into an Ada -- subprogram that raises an exception to warn the user. N := Make_Exception_Declaration (Make_Defining_Identifier (EN (e_nyi))); ADU.Append_Node_To_List (N, Declarations); N := Make_Raise_Statement (Make_Defining_Identifier (EN (e_nyi))); ADU.Append_Node_To_List (N, Statements); return Make_Subprogram_Implementation (Spec, Declarations, Statements); when subprogram_opaque_c => -- An opaque C AADL subprogram is a subprogram which is -- implemented by a C subprogram. We perform the mapping -- between the two subprograms using the Ada `Import' -- pragma in the specification. Therefore, we have -- nothing to do in the body. return No_Node; when subprogram_opaque_ada_95 => -- An opaque Ada AADL subprogram is a subprogram which is -- implemented by and Ada subprogram. We perform the -- mapping between the two subprogram using the Ada -- renaming facility. -- Add the proper `with' clause N := Make_Designator (Unit_Name (Get_Source_Name (S))); Add_With_Package (N); -- Perform the renaming N := Make_Designator (Local_Name (Get_Source_Name (S)), Unit_Name (Get_Source_Name (S))); ADN.Set_Renamed_Entity (Spec, N); return Spec; when subprogram_pure_call_sequence => -- A pure call sequence subprogram is a subprogram that -- has exactly one call sequence. The behaviour of this -- subprogram is simply the call to the subprograms -- present in its call list. Handle_Call_Sequence (S, First_Node (Calls (S)), Declarations, Statements); return ADU.Make_Subprogram_Implementation (Spec, Declarations, Statements); when subprogram_hybrid_ada_95 => -- Hybrid subprograms are subprograms that contain more -- that one call sequence. -- Declare the Status local variable N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (PN (p_status)), Object_Definition => Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (S))); ADU.Append_Node_To_List (N, Declarations); -- Initialise the record fields that correspond to IN -- parameters. if not AAU.Is_Empty (Features (S)) then F := First_Node (Features (S)); while Present (F) loop if Kind (F) = k_parameter_instance and then Is_In (F) then N := Make_Assignment_Statement (Make_Designator (To_Ada_Name (Display_Name (Identifier (F))), PN (p_status)), Make_Designator (To_Ada_Name (Display_Name (Identifier (F))))); ADU.Append_Node_To_List (N, Statements); end if; F := Next_Node (F); end loop; end if; Profile := New_List (ADN.k_parameter_profile); -- Append the 'Status' variable to the call profile N := Make_Defining_Identifier (PN (p_status)); ADU.Append_Node_To_List (N, Profile); -- For each call sequence, we add the subprogram that -- handles it. Call_Seq := First_Node (Calls (S)); while Present (Call_Seq) loop N := Make_Attribute_Designator (Make_Defining_Identifier (Map_Ada_Call_Seq_Subprogram_Name (S, Call_Seq)), a_access); ADU.Append_Node_To_List (N, Profile); Call_Seq := Next_Node (Call_Seq); end loop; -- Call the implementation subprogram -- Add the proper `with' clause N := Make_Designator (Unit_Name (Get_Source_Name (S))); Add_With_Package (N); N := Make_Designator (Local_Name (Get_Source_Name (S)), Unit_Name (Get_Source_Name (S))); N := Make_Subprogram_Call (ADN.Defining_Identifier (N), Profile); ADU.Append_Node_To_List (N, Statements); -- Update the OUT parameters from the corresponding -- record fields. if not AAU.Is_Empty (Features (S)) then F := First_Node (Features (S)); while Present (F) loop if Kind (F) = k_parameter_instance and then Is_Out (F) then N := Make_Assignment_Statement (Make_Designator (To_Ada_Name (Display_Name (Identifier (F)))), Make_Designator (To_Ada_Name (Display_Name (Identifier (F))), PN (p_status))); ADU.Append_Node_To_List (N, Statements); end if; F := Next_Node (F); end loop; end if; return Make_Subprogram_Implementation (Spec, Declarations, Statements); when subprogram_opaque_asn1_wrapped => -- An opaque ASN1 subprogram is mapped onto an Ada -- subprogram that raises an exception to warn the user. N := Make_Exception_Declaration (Make_Defining_Identifier (EN (e_nyi))); ADU.Append_Node_To_List (N, Declarations); N := Make_Raise_Statement (Make_Defining_Identifier (EN (e_nyi))); ADU.Append_Node_To_List (N, Statements); return Make_Subprogram_Implementation (Spec, Declarations, Statements); when others => Display_Located_Error (Loc (S), "This kind of subprogram is not supported: " & Get_Subprogram_Kind (S)'img, Fatal => True); return No_Node; end case; end Map_Ada_Subprogram_Body; -------------------------------------- -- Map_Ada_Call_Seq_Subprogram_Spec -- -------------------------------------- function Map_Ada_Call_Seq_Subprogram_Spec (Spg : node_id; Seq : node_id) return node_id is Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin N := Make_Parameter_Specification (Make_Defining_Identifier (PN (p_status)), Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg)), mode_inout); ADU.Append_Node_To_List (N, Profile); N := Make_Subprogram_Specification (Make_Defining_Identifier (Map_Ada_Call_Seq_Subprogram_Name (Spg, Seq)), Profile); return N; end Map_Ada_Call_Seq_Subprogram_Spec; -------------------------------------- -- Map_Ada_Call_Seq_Subprogram_Body -- -------------------------------------- function Map_Ada_Call_Seq_Subprogram_Body (Spg : node_id; Seq : node_id) return node_id is Spec : constant node_id := Map_Ada_Call_Seq_Subprogram_Spec (Spg, Seq); Declarations : constant list_id := New_List (ADN.k_declaration_list); Statements : constant list_id := New_List (ADN.k_statement_list); begin Handle_Call_Sequence (Spg, Seq, Declarations, Statements); return Make_Subprogram_Implementation (Spec, Declarations, Statements); end Map_Ada_Call_Seq_Subprogram_Body; ------------------------------------ -- Map_Ada_Subprogram_Status_Name -- ------------------------------------ function Map_Ada_Subprogram_Status_Name (S : node_id) return name_id is begin pragma assert (Is_Subprogram (S) or else Kind (S) = k_call_instance); Get_Name_String (ADU.To_Ada_Name (Display_Name (Identifier (S)))); Add_Str_To_Name_Buffer ("_Status"); return Name_Find; end Map_Ada_Subprogram_Status_Name; -------------------------------------- -- Map_Ada_Call_Seq_Subprogram_Name -- -------------------------------------- function Map_Ada_Call_Seq_Subprogram_Name (Spg : node_id; Seq : node_id) return name_id is Spg_Name : name_id; Seg_Name : name_id; begin pragma assert (Is_Subprogram (Spg) and then Kind (Seq) = k_call_sequence_instance); Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Spg))); Seg_Name := ADU.To_Ada_Name (Display_Name (Identifier (Seq))); Get_Name_String (Spg_Name); Add_Char_To_Name_Buffer ('_'); Get_Name_String_And_Append (Seg_Name); return Name_Find; end Map_Ada_Call_Seq_Subprogram_Name; ---------------------------------- -- Map_Ada_Call_Seq_Access_Name -- ---------------------------------- function Map_Ada_Call_Seq_Access_Name (S : node_id) return name_id is Spg_Name : name_id; begin pragma assert (Is_Subprogram (S)); Spg_Name := ADU.To_Ada_Name (Display_Name (Identifier (S))); Get_Name_String (Spg_Name); Add_Str_To_Name_Buffer ("_Sequence_Access"); return Name_Find; end Map_Ada_Call_Seq_Access_Name; ----------------------------- -- Map_Ada_Call_Seq_Access -- ----------------------------- function Map_Ada_Call_Seq_Access (S : node_id) return node_id is Profile : constant list_id := New_List (ADN.k_parameter_profile); N : node_id; begin N := Make_Parameter_Specification (Make_Defining_Identifier (PN (p_status)), Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (S)), mode_inout); ADU.Append_Node_To_List (N, Profile); N := Make_Subprogram_Specification (No_Node, Profile); N := Make_Full_Type_Declaration (Make_Defining_Identifier (Map_Ada_Call_Seq_Access_Name (S)), Make_Access_Type_Definition (N)); return N; end Map_Ada_Call_Seq_Access; ------------------------------- -- Map_Ada_Subprogram_Status -- ------------------------------- function Map_Ada_Subprogram_Status (S : node_id) return node_id is Fields : constant list_id := New_List (ADN.k_component_list); F : node_id; N : node_id; begin pragma assert (Is_Subprogram (S)); if not AAU.Is_Empty (Features (S)) then F := First_Node (Features (S)); while Present (F) loop N := Make_Component_Declaration (Map_Ada_Defining_Identifier (F), Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); ADU.Append_Node_To_List (N, Fields); F := Next_Node (F); end loop; else Display_Located_Error (Loc (S), "This hybrid subprogram has no parameters", Fatal => True); end if; N := Make_Full_Type_Declaration (Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (S)), Make_Record_Definition (Fields)); return N; end Map_Ada_Subprogram_Status; -------------------------- -- Handle_Call_Sequence -- -------------------------- procedure Handle_Call_Sequence (Caller : node_id; Call_Seq : node_id; Declarations : list_id; Statements : list_id) is Spg_Call : node_id; Spg : node_id; Destination_F : node_id; Source_F : node_id; Source_Parent : node_id; Call_Profile : list_id; Param_Value : node_id; Owner_Object : node_id; N : node_id; M : node_id; F : node_id; Parent : node_id; Hybrid : constant Boolean := Is_Subprogram (Caller) and then Get_Subprogram_Kind (Caller) = subprogram_hybrid_ada_95; begin -- The lists have to be created if Declarations = No_List or else Statements = No_List then raise Program_Error with "Lists have to be created before any call " & "to Handle_Call_Sequence"; end if; -- The call sequence must contain at least one call to a -- subprogram. if AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Display_Located_Error (Loc (Call_Seq), "Empty call sequence", Fatal => False, Warning => True); return; end if; Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Spg := Corresponding_Instance (Spg_Call); Call_Profile := New_List (ADN.k_list_id); if not AAU.Is_Empty (Features (Spg)) then F := First_Node (Features (Spg)); while Present (F) loop if Kind (F) = k_parameter_instance and then Is_Out (F) then -- Raise an error if the parameter is not connected -- to any source. if AAU.Length (Destinations (F)) = 0 then Display_Located_Error (Loc (F), "This OUT parameter is not connected to" & " any destination", Fatal => True); elsif AAU.Length (Destinations (F)) > 1 then Display_Located_Error (Loc (F), "This IN parameter has too many destinations", Fatal => True); end if; -- At this point, we have a subprogram call -- parameter that has exactly one destination. Destination_F := Item (First_Node (Destinations (F))); -- For each OUT parameter, we declare a local -- variable if the OUT parameter is connected to -- another subprogram call or if the caller is a -- thread. Otherwise, we use the corresponding -- caller subprogram parameter. -- The parameter association value takes 4 possible -- values (see the (1), (2), (3) and (4) comments -- below. if Is_Thread (Caller) then -- Here we declare a variable based on the -- thread feature name. N := Make_Object_Declaration (Defining_Identifier => Map_Ada_Defining_Identifier (Destination_F, 'V'), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (Destination_F))); ADU.Append_Node_To_List (N, Declarations); -- (1) If we declared a local variable, we use it -- as parameter value. Param_Value := Map_Ada_Defining_Identifier (Destination_F, 'V'); elsif Parent_Component (Destination_F) /= Caller then -- Here, we map the variable name from the -- subprogram *call* name and the feature -- name. This avoids name clashing when a -- subprogram calls twice the same subprogram. N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Ada_Full_Parameter_Name (Spg_Call, F)), Object_Definition => Map_Ada_Data_Type_Designator (Corresponding_Instance (F))); ADU.Append_Node_To_List (N, Declarations); -- (2) If we declared a local variable, we use it -- as parameter value. Param_Value := Make_Designator (Map_Ada_Full_Parameter_Name (Spg_Call, F)); elsif Hybrid then -- (3) If the calleD parameter is connected to -- the calleR parameter and then the calleR -- IS hybrid, then we use the 'Status' -- record field corresponding to the calleR -- parameter. Param_Value := Make_Designator (To_Ada_Name (Display_Name (Identifier (F))), PN (p_status)); else -- (4) If the calleD parameter is connected to -- the calleR parameter and then then calleR -- is NOT hybrid, then we use simply the -- corresponding paremeter of the calleR. Param_Value := Map_Ada_Defining_Identifier (Destination_F); end if; -- For each OUT parameter we build a parameter -- association of the actual profile of the -- implementation subprogram call => -- . N := Make_Parameter_Association (Selector_Name => Map_Ada_Defining_Identifier (F), Actual_Parameter => Param_Value); ADU.Append_Node_To_List (N, Call_Profile); elsif Kind (F) = k_parameter_instance and then Is_In (F) then -- Raise an error if the parameter is not connected -- to any source. if AAU.Length (Sources (F)) = 0 then Display_Located_Error (Loc (F), "This IN parameter is not connected to" & " any source", Fatal => True); elsif AAU.Length (Sources (F)) > 1 then Display_Located_Error (Loc (F), "This IN parameter has too many sources", Fatal => True); end if; -- Here we have an IN parameter with exactly one -- source. Source_F := Item (First_Node (Sources (F))); -- Get the source feature parent Source_Parent := Parent_Component (Source_F); -- The parameter value of the built parameter -- association can take 4 different values (see -- comments (1), (2), (3) and (4) below). if Is_Thread (Source_Parent) then -- (1) If the Parent of 'Source_F' is a thread, -- then we use the local variable corresponding -- to the IN port. Param_Value := Map_Ada_Defining_Identifier (Source_F, 'V'); elsif Source_Parent /= Caller then -- (2) If the the source call is different from -- the englobing subprogram, we use the -- formerly declared variable. Param_Value := Make_Designator (Map_Ada_Full_Parameter_Name (Parent_Subcomponent (Source_Parent), Source_F)); elsif Hybrid then -- (3) If the calleD parameter is connected to -- the calleR parameter and then then calleR -- IS hybrid, the we use the 'Status' record -- field corresponding to the calleR -- parameter. Param_Value := Make_Selected_Component (Make_Defining_Identifier (PN (p_status)), Map_Ada_Defining_Identifier (Source_F)); else -- (4) If the calleD parameter is connected to -- the calleR parameter and then then calleR -- is NOT hybrid, then we use simply the -- corresponding paremeter of the calleR. Param_Value := Map_Ada_Defining_Identifier (Source_F); end if; -- For each IN parameter we build a parameter -- association association of the actual profile of -- the implmentaion subprogram call => -- . N := Make_Parameter_Association (Selector_Name => Map_Ada_Defining_Identifier (F), Actual_Parameter => Param_Value); ADU.Append_Node_To_List (N, Call_Profile); end if; F := Next_Node (F); end loop; end if; if not AAU.Is_Empty (Path (Spg_Call)) then -- FIXME: Feature subprograms that have OUT ports are not -- supported yet. if Has_Out_Ports (Spg) then Display_Located_Error (Loc (Spg), "Feature subprograms that have OUT ports are not" & " supported yet", Fatal => True); end if; -- If this is a feature subprogram call, generate a call -- to the corresponding method. N := Message_Comment ("Invoking method"); ADU.Append_Node_To_List (N, Statements); N := Map_Ada_Defining_Identifier (Item (Last_Node (Path (Spg_Call)))); -- Get the actual owner object -- FIXME: THIS WORKS ONLY FOR A LOCAL OBJECT Owner_Object := Get_Actual_Owner (Spg_Call); Set_Homogeneous_Parent_Unit_Name (N, Extract_Designator (ADN.Object_Node (Backend_Node (Identifier (Owner_Object))))); N := Make_Subprogram_Call (N, Call_Profile); ADU.Append_Node_To_List (N, Statements); else -- If this is a classic subprogram, and if it has OUT -- ports, we declare an additional status variable and -- pass it to the implementation as the last INOUT -- parameter. if Has_Out_Ports (Spg) then N := Make_Object_Declaration (Defining_Identifier => Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg_Call)), Object_Definition => Extract_Designator (ADN.Type_Definition_Node (Backend_Node (Identifier (Spg))))); ADU.Append_Node_To_List (N, Declarations); N := Make_Parameter_Association (Make_Defining_Identifier (PN (p_status)), Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg_Call))); ADU.Append_Node_To_List (N, Call_Profile); end if; -- Call the implementation. N := Message_Comment ("Call implementation"); ADU.Append_Node_To_List (N, Statements); N := Make_Subprogram_Call (Extract_Designator (ADN.Subprogram_Node (Backend_Node (Identifier (Spg)))), Call_Profile); ADU.Append_Node_To_List (N, Statements); -- After the implementation is called and if the called -- subprogram has OUT port, we trigger the destination of -- these ports, which are out ports of the containing -- thread or subprogram. if Has_Out_Ports (Spg) then F := First_Node (Features (Spg)); while Present (F) loop if Kind (F) = k_port_spec_instance then -- Verify whether the port has been triggered -- then send the value to all its destinations. declare D : node_id; Profile : list_id; Aggr : list_id; St : constant list_id := ADU.New_List (ADN.k_statement_list); begin D := First_Node (Destinations (F)); while Present (D) loop -- D is necessarily a feature of Caller, -- otherwise we have a serious problem. pragma assert (Parent_Component (Item (D)) = Caller); Profile := ADU.New_List (ADN.k_list_id); -- If the caller is a subprogram, then the -- profile of the Put_Value has a 'Status' -- parameter. if Is_Subprogram (Caller) then N := Make_Defining_Identifier (PN (p_status)); ADU.Append_Node_To_List (N, Profile); end if; Aggr := ADU.New_List (ADN.k_list_id); N := Make_Component_Association (Make_Defining_Identifier (CN (c_port)), Map_Ada_Defining_Identifier (Item (D))); ADU.Append_Node_To_List (N, Aggr); if Nodes.Is_Data (Item (D)) then N := Map_Ada_Defining_Identifier (F); -- We do not put use clause to avoid -- name clashing, so enumerators have -- to be qualified. M := Extract_Designator (ADN.Port_Enumeration_Node (Backend_Node (Identifier (Spg)))); Parent := ADN.Parent_Unit_Name (M); N := Make_Selected_Component (Parent, N); N := Make_Qualified_Expression (M, Make_Record_Aggregate (Make_List_Id (N))); N := Make_Subprogram_Call (Extract_Designator (ADN.Get_Value_Node (Backend_Node (Identifier (Spg)))), Make_List_Id (Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg_Call)), N)); N := Make_Component_Association (Make_Defining_Identifier (Map_Ada_Component_Name (Item (D))), Make_Selected_Component (N, Make_Defining_Identifier (Map_Ada_Component_Name (F)))); ADU.Append_Node_To_List (N, Aggr); end if; N := Make_Qualified_Expression (Extract_Designator (ADN.Port_Interface_Node (Backend_Node (Identifier (Caller)))), Make_Record_Aggregate (Aggr)); ADU.Append_Node_To_List (N, Profile); -- Call, the Put_Value routine -- corresponding to the destination. N := Make_Subprogram_Call (Extract_Designator (ADN.Put_Value_Node (Backend_Node (Identifier (Caller)))), Profile); ADU.Append_Node_To_List (N, St); D := Next_Node (D); end loop; -- Make the if statement Profile := ADU.New_List (ADN.k_list_id); N := Make_Defining_Identifier (Map_Ada_Subprogram_Status_Name (Spg_Call)); ADU.Append_Node_To_List (N, Profile); N := Map_Ada_Defining_Identifier (F); -- We do not put use clause to avoid name -- clashing, so enumerators have to be fully -- qualified. M := Extract_Designator (ADN.Port_Enumeration_Node (Backend_Node (Identifier (Spg)))); Parent := ADN.Parent_Unit_Name (M); N := Make_Selected_Component (Parent, N); N := Make_Qualified_Expression (M, Make_Record_Aggregate (Make_List_Id (N))); ADU.Append_Node_To_List (N, Profile); N := Make_Subprogram_Call (Extract_Designator (ADN.Get_Count_Node (Backend_Node (Identifier (Spg)))), Profile); N := Make_Expression (N, op_greater_equal, Make_Literal (ADV.New_Integer_Value (1, 1, 10))); N := Make_If_Statement (Condition => N, Then_Statements => St); ADU.Append_Node_To_List (N, Statements); end; end if; F := Next_Node (F); end loop; end if; end if; Spg_Call := Next_Node (Spg_Call); end loop; end Handle_Call_Sequence; --------------------------- -- Get_Ada_Default_Value -- --------------------------- function Get_Ada_Default_Value (D : node_id) return node_id is Data_Type : supported_data_type; Result : node_id; begin pragma assert (Is_Data (D)); Data_Type := Get_Data_Type (D); case Data_Type is when data_integer => -- For integers, default value is 0 Result := ADU.Make_Literal (ADV.New_Integer_Value (0, 1, 10)); when data_float | data_fixed => -- For reals, the default value is 0.0 Result := ADU.Make_Literal (ADV.New_Floating_Point_Value (0.0)); when data_boolean => -- For booleans, the default value is FALSE Result := ADU.Make_Literal (ADV.New_Boolean_Value (False)); when data_character => -- For characters, the default value is the space ' ' Result := ADU.Make_Literal (ADV.New_Character_Value (Character'pos (' '))); when data_wide_character => -- For wide characters, the default value is the wide -- space ' '. Result := ADU.Make_Literal (ADV.New_Character_Value (Wide_Character'pos (' '), True)); when data_string => Display_Located_Error (Loc (D), "Bounded strings default values not supported yet!", Fatal => True); when data_wide_string => Display_Located_Error (Loc (D), "Bounded wide strings default values not supported yet!", Fatal => True); when data_array => -- The default value for an array type is an array -- aggregate of the default value of the array element -- type. Result := Make_Record_Aggregate (Make_List_Id (Make_Element_Association (No_Node, Get_Ada_Default_Value (Corresponding_Instance (First_Node (Subcomponents (D))))))); when data_record => -- For data record, the default value is an aggregate -- list of default values of all the record aggregates. declare Aggregates : constant list_id := ADU.New_List (ADN.k_component_list); S : node_id; C : node_id; begin if not AAU.Is_Empty (Subcomponents (D)) then S := First_Node (Subcomponents (D)); while Present (S) loop C := ADU.Make_Component_Association (Map_Ada_Defining_Identifier (S), Get_Ada_Default_Value (Corresponding_Instance (S))); ADU.Append_Node_To_List (C, Aggregates); S := Next_Node (S); end loop; Result := ADU.Make_Record_Aggregate (Aggregates); else Display_Located_Error (Loc (D), "Record types must not be empty!", Fatal => True); end if; end; when data_with_accessors => -- This is definitely a code generation error raise Program_Error with "Data types with accessors should" & " not have default values"; when others => Display_Located_Error (Loc (D), "Cannot generate default value for type", Fatal => False, Warning => True); Result := No_Node; end case; return Result; end Get_Ada_Default_Value; ------------------------------------------- -- Map_Ada_Namespace_Defining_Identifier -- ------------------------------------------- function Map_Ada_Namespace_Defining_Identifier (N : node_id; Prefix : String := "") return node_id is Name_List : list_id; I : node_id; Id : node_id; Parent_Id : node_id := No_Node; begin if Name (Identifier (N)) = No_Name then -- This is the unnamed namespace if Prefix = "" then -- Display an error if the user did not give a prefix raise Program_Error with "You must provide a prefix to map the" & " unnamed namespace"; end if; return ADU.Make_Defining_Identifier (Get_String_Name (Prefix)); else -- This is a "classical" namespace obtained from the -- instanciation of an AADL package. Name_List := Split_Name (N); if Prefix /= "" then Parent_Id := ADU.Make_Defining_Identifier (Get_String_Name (Prefix)); end if; I := First_Node (Name_List); while Present (I) loop Id := ADU.Make_Defining_Identifier (Display_Name (I)); ADN.Set_Parent_Unit_Name (Id, Parent_Id); Parent_Id := Id; I := Next_Node (I); end loop; return Id; end if; end Map_Ada_Namespace_Defining_Identifier; ------------------ -- Map_Ada_Size -- ------------------ function Map_Ada_Size (S : size_type) return unsigned_long_long is begin case S.U is when bit => -- If the size can be converted into byte, we are OK, -- else, this is an error. if S.S mod 8 = 0 then return S.S / 8; else return 0; end if; when Properties.byte => return S.S; when kilo_byte => return S.S * 1_000; when mega_byte => return S.S * 1_000_000; when giga_byte => return S.S * 1_000_000_000; end case; end Map_Ada_Size; ---------------------------------- -- Check_Connection_Consistency -- ---------------------------------- procedure Check_Connection_Consistency (C : node_id) is B : node_id; C_Src : node_id; C_Dst : node_id; P_Src : node_id; P_Dst : node_id; procedure Check_Port_Consistency (P : node_id); -- Check that a port belongs to a process and complains with an -- error otherwise procedure Check_Processes_Bus_Access (P : node_id; Bus : node_id); -- Check that the process P have access to the bus 'Bus' -- through its bound processor. ---------------------------- -- Check_Port_Consistency -- ---------------------------- procedure Check_Port_Consistency (P : node_id) is begin if not Is_Process (Parent_Component (P)) then Display_Located_Error (Loc (P), "The parent of this port is not a process and it" & " is involved in a system-level connection in " & Image (Loc (C)), Fatal => True); end if; end Check_Port_Consistency; -------------------------------- -- Check_Processes_Bus_Access -- -------------------------------- procedure Check_Processes_Bus_Access (P : node_id; Bus : node_id) is CPU : node_id; F : node_id := No_Node; S : node_id; begin -- Get the processor to which P is bound CPU := Get_Bound_Processor (P); -- Loop on the features of CPU to find the required access -- to the Bus if not AAU.Is_Empty (Features (CPU)) then F := First_Node (Features (CPU)); Outer_Loop : while Present (F) loop if Kind (F) = k_subcomponent_access_instance then -- Verify that the required access is indeed connected to -- the bus subcomponent correspondiong to Bus if not AAU.Is_Empty (Sources (F)) then S := First_Node (Sources (F)); while Present (S) loop exit Outer_Loop when Item (S) = Parent_Subcomponent (B); S := Next_Node (S); end loop; end if; end if; F := Next_Node (F); end loop Outer_Loop; end if; if No (F) then -- This means we went through all the previous loop -- without finding any matching bus access or that we did -- never enter the loop. Display_Located_Error (Loc (Parent_Subcomponent (CPU)), "This process has no access to the bus declared at " & Image (Loc (Parent_Subcomponent (Bus))), Fatal => True); end if; end Check_Processes_Bus_Access; begin pragma assert (Kind (C) = k_connection_instance); -- We only check connection at system level if not Is_System (Parent_Component (C)) then return; end if; -- We only check port connections if not (Get_Category_Of_Connection (C) in port_connection_type'range) then return; end if; -- Get the connecion bus B := Get_Bound_Bus (C); -- Get the connection extremities C_Src := Get_Referenced_Entity (Source (C)); C_Dst := Get_Referenced_Entity (Destination (C)); -- Check that the connection connects two ports if Kind (C_Src) /= k_port_spec_instance or else Kind (C_Src) /= k_port_spec_instance then -- FIXME: May be refined in the future when distributed -- shared variable will be supported. Display_Located_Error (Loc (C), "One of the extremities of this connection is not a port", Fatal => True); end if; -- Check that the connected ports belongs to processes Check_Port_Consistency (C_Src); Check_Port_Consistency (C_Dst); -- Get the processes P_Src := Parent_Component (C_Src); P_Dst := Parent_Component (C_Dst); -- Check that the two processes have an access to the Bus to -- which the connection is bound through their respective bound -- processors. Check_Processes_Bus_Access (P_Src, B); Check_Processes_Bus_Access (P_Dst, B); -- Everything is OK end Check_Connection_Consistency; ------------------------------ -- Check_Thread_Consistency -- ------------------------------ procedure Check_Thread_Consistency (T : node_id) is begin pragma assert (Is_Thread (T)); -- Check implementation kind if Get_Thread_Implementation_Kind (T) = thread_unknown then Display_Located_Error (Loc (T), "Unknown thread implementation kind", Fatal => True); end if; end Check_Thread_Consistency; ------------------------------------ -- Get_Subcomponent_Access_Source -- ------------------------------------ function Get_Subcomponent_Access_Source (S : node_id) return node_id is Src : node_id; begin pragma assert (Kind (S) = k_subcomponent_access_instance); -- Raise an error if the provided access is not connected if AAU.Is_Empty (Sources (S)) then Display_Located_Error (Loc (S), "Required access not connected to anything", Fatal => True); end if; -- Loop on the sources of the access until finding a -- subcomponent. Src := First_Node (Sources (S)); while Present (Src) loop exit when Kind (Item (Src)) = k_subcomponent_instance; -- Raise an error if the provided access is not connected if AAU.Is_Empty (Sources (Item (Src))) then Display_Located_Error (Loc (Item (Src)), "Required access not connected to anything", Fatal => True); end if; Src := First_Node (Sources (Item (Src))); end loop; -- If Src is No_Node, this means that the required access chain -- does not end with a subcomponenet as stated by the AADL -- standard. if No (Src) then Display_Located_Error (Loc (S), "Required access chain does not end with a subcomponent", Fatal => True); end if; return Item (Src); end Get_Subcomponent_Access_Source; end Ocarina.Generators.Utils;