------------------------------------------------------------- ------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . N 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 Namet; with Utils; with Ocarina.Entities.Components; package body Ocarina.Nutils is use Namet; use Utils; use Ocarina.Entities; use Ocarina.Entities.Components; ------------------- -- First_Homonym -- ------------------- function First_Homonym (N : Node_Id) return Node_Id is HN : constant Name_Id := Name (N); begin return Node_Id (Get_Name_Table_Info (HN)); end First_Homonym; ----------------------- -- Set_First_Homonym -- ----------------------- procedure Set_First_Homonym (N : Node_Id; V : Node_Id) is begin Set_Name_Table_Info (Name (N), Int (V)); end Set_First_Homonym; ----------------------- -- Push_Node_To_List -- ----------------------- procedure Push_Node_To_List (E : Node_Id; L : List_Id) is First_L : constant Node_Id := First_Node (L); Last_E : Node_Id; -- the last element of E Next_E : Node_Id; begin Set_First_Node (L, E); Last_E := E; loop Next_E := Next_Node (Last_E); exit when No (Next_E); Last_E := Next_E; end loop; if No (First_L) then -- list is empty Set_Last_Node (L, Last_E); else Set_Next_Node (Last_E, First_L); end if; end Push_Node_To_List; ------------------------- -- Append_List_To_List -- ------------------------- procedure Append_List_To_List (S : List_Id; D : in out List_Id) is begin if Present (D) then Append_Node_To_List (First_Node (S), D); else -- This is highly dangerous. Append should be a copy -- operation. D := S; end if; end Append_List_To_List; ------------------------- -- Append_Node_To_List -- ------------------------- procedure Append_Node_To_List (E : Node_Id; L : List_Id) is Last : Node_Id; begin Last := Last_Node (L); if No (Last) then Set_First_Node (L, E); else Set_Next_Node (Last, E); end if; Last := E; while Present (Last) loop Set_Last_Node (L, Last); Last := Next_Node (Last); end loop; end Append_Node_To_List; ---------------- -- Have_Modes -- ---------------- function Have_Modes (In_Modes : Node_Id) return Boolean is begin return Present (In_Modes) and then not Is_Empty (Modes (In_Modes)); end Have_Modes; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List_Id) return Boolean is begin return L = No_List or else No (First_Node (L)); end Is_Empty; ------------ -- Length -- ------------ function Length (L : List_Id) return Natural is N : Node_Id; C : Natural := 0; begin if not Is_Empty (L) then N := First_Node (L); while Present (N) loop C := C + 1; N := Next_Node (N); end loop; end if; return C; end Length; -------------------------- -- Make_Annotation_Item -- -------------------------- function Make_Annotation_Item (Annotation_Node : Node_Id; Annotation_Name : Name_Id; Annotation_Info : Node_Id) return Node_Id is Node : constant Node_Id := New_Node (K_Annotation_Item, No_Location); begin Set_Annotation_Node (Node, Annotation_Node); Set_Annotation_Name (Node, Annotation_Name); Set_Annotation_Info (Node, Annotation_Info); return Node; end Make_Annotation_Item; --------------------- -- Make_Identifier -- --------------------- function Make_Identifier (Loc : Location; Name : Name_Id; Display_Name : Name_Id; Entity : Node_Id) return Node_Id is Node : constant Node_Id := New_Node (K_Identifier, Loc); begin Set_Name (Node, Name); Set_Display_Name (Node, Display_Name); Set_Corresponding_Entity (Node, Entity); return Node; end Make_Identifier; -------------------- -- Make_Container -- -------------------- function Make_Node_Container (Item : Node_Id; Extra_Item : Node_Id := No_Node) return Node_Id is Container : constant Node_Id := New_Node (K_Node_Container, Loc (Item)); begin Set_Item (Container, Item); Set_Extra_Item (Container, Extra_Item); return Container; end Make_Node_Container; -------------- -- New_List -- -------------- function New_List (Kind : Node_Kind; Loc : Location) return List_Id is begin return List_Id (New_Node (Kind, Loc)); end New_List; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind; Loc : Location) return Node_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); Set_Loc (N, Loc); return N; end New_Node; ----------------- -- Reset_Nodes -- ----------------- procedure Reset_Nodes is begin Entries.Init; end Reset_Nodes; -------------------------------- -- Remove_Last_Node_From_List -- -------------------------------- function Remove_Last_Node_From_List (L : List_Id) return Node_Id is Previous : Node_Id; Current : Node_Id; Next : Node_Id; begin if No (L) then -- invalid list return No_Node; end if; Previous := First_Node (L); if No (Previous) then -- list is empty return No_Node; end if; Current := Next_Node (Previous); if No (Current) then -- list contains only one element Set_First_Node (L, No_Node); -- erase L first node Set_Last_Node (L, No_Node); return Previous; end if; loop Next := Next_Node (Current); exit when No (Next); Previous := Current; Current := Next; end loop; Set_Next_Node (Previous, No_Node); Set_Last_Node (L, Previous); return Current; end Remove_Last_Node_From_List; --------------------------- -- Remove_Node_From_List -- --------------------------- procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is C : Node_Id; begin C := First_Node (L); if C = E then Set_First_Node (L, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, No_Node); end if; else while Present (C) loop if Next_Node (C) = E then Set_Next_Node (C, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, C); end if; exit; end if; C := Next_Node (C); end loop; end if; end Remove_Node_From_List; ---------------- -- Split_Name -- ---------------- function Split_Name (N : Node_Id) return List_Id is Name_List : List_Id; D_Name : Name_Id; L_Name : Name_Id; begin if No (Identifier (N)) or else Display_Name (Identifier (N)) = No_Name then Name_List := No_List; else Get_Name_String (Display_Name (Identifier (N))); -- To get uniform case handling of the separation between -- names and the end of the full name Add_Char_To_Name_Buffer (':'); declare Package_Name : constant String := Name_Buffer (Name_Buffer'First .. Name_Len); Lower_Index, Upper_Index : Natural := Package_Name'First; Identifier : Node_Id; begin Name_List := New_List (K_List_Id, No_Location); while Upper_Index <= Package_Name'Last loop -- There are two kinds of package names: -- 1 - "Name1::Name2::.." names for which a list containing -- all the names is built -- 2 - "One_Single_Name" names for which a single element -- list is built if Name_Buffer (Upper_Index) = ':' then Set_Str_To_Name_Buffer (Package_Name (Lower_Index .. Upper_Index - 1)); D_Name := Name_Find; L_Name := To_Lower (D_Name); Identifier := Make_Identifier (No_Location, L_Name, D_Name, No_Node); Append_Node_To_List (Identifier, Name_List); -- skip the second ':' Upper_Index := Upper_Index + 1; -- Point to the beginning of the next name Lower_Index := Upper_Index + 1; end if; Upper_Index := Upper_Index + 1; end loop; end; end if; return Name_List; end Split_Name; ----------------------------- -- Get_Parent_Package_Name -- ----------------------------- function Get_Parent_Package_Name (Pkg : Node_Id) return Name_Id is List : constant List_Id := Split_Name (Pkg); Id : Node_Id; begin if Length (List) <= 1 then -- The package has no parent return No_Name; end if; Id := First_Node (List); Name_Len := 0; while Present (Id) loop Get_Name_String_And_Append (Name (Id)); Id := Next_Node (Id); -- Loop until the before last element exit when No (Next_Node (Id)); Add_Str_To_Name_Buffer ("::"); end loop; return Name_Find; end Get_Parent_Package_Name; ----------------------------------- -- Compute_Full_Name_Of_Instance -- ----------------------------------- function Compute_Full_Name_Of_Instance (Instance : Node_Id; Display_Name : Boolean := False; Keep_Root_System : Boolean := True) return Name_Id is pragma Assert (Kind (Instance) = K_Component_Instance or else Kind (Instance) = K_Subcomponent_Instance or else Kind (Instance) = K_Namespace_Instance or else Kind (Instance) = K_Connection_Instance or else Kind (Instance) = K_Port_Spec_Instance or else Kind (Instance) = K_Parameter_Instance or else Kind (Instance) = K_Call_Sequence_Instance or else Kind (Instance) = K_Call_Instance); Parent_Name : Name_Id := No_Name; Entity_Name : Name_Id := No_Name; Full_Name : Name_Id := No_Name; L : List_Id; N : Node_Id; begin -- A full name is the concatenation of the names of the -- subdeclarations (subcomponents, connections, etc.) from the -- top level system. The name of this system is also part of -- the full name. case Kind (Instance) is when K_Component_Instance => if Get_Category_Of_Component (Instance) = CC_Subprogram then L := Split_Name (Namespace (Instance)); Set_Str_To_Name_Buffer (""); if not Is_Empty (L) then N := First_Node (L); while Present (N) loop if Display_Name then Get_Name_String_And_Append (Nodes.Display_Name (N)); else Get_Name_String_And_Append (Name (N)); end if; Add_Char_To_Name_Buffer ('_'); N := Next_Node (N); end loop; end if; Get_Name_String_And_Append (Get_Name_Of_Entity (Instance, Display_Name)); Full_Name := Name_Find; elsif No (Parent_Subcomponent (Instance)) then -- These two cases we return only the name of the -- entity: -- 1 - If we cannot go upper in the instance tree, we -- get the instance name. -- 2 - If we deal with a subprogram. -- FIXME: This needs more effort scince a subprogram -- name should be Namespace1_Namespace2_..._Spg. Full_Name := Get_Name_Of_Entity (Instance, Display_Name); elsif Get_Category_Of_Component (Parent_Component (Parent_Subcomponent (Instance))) = CC_System and then not Keep_Root_System then -- If there is a corresponding subcomponent but its -- parent is a system, we get the name of the -- subcomponent unless the user wanted to go upper in -- the instance tree Full_Name := Get_Name_Of_Entity (Parent_Subcomponent (Instance), Display_Name); else -- General case, we go upper in the instance tree Full_Name := Compute_Full_Name_Of_Instance (Parent_Subcomponent (Instance), Display_Name, Keep_Root_System); end if; when K_Call_Instance => Parent_Name := Compute_Full_Name_Of_Instance (Parent_Sequence (Instance), Display_Name, Keep_Root_System); Get_Name_String (Parent_Name); Add_Str_To_Name_Buffer ("_"); Get_Name_String_And_Append (Get_Name_Of_Entity (Instance, Display_Name)); Full_Name := Name_Find; when others => Parent_Name := Compute_Full_Name_Of_Instance (Parent_Component (Instance), Display_Name, Keep_Root_System); Get_Name_String (Parent_Name); Entity_Name := Get_Name_Of_Entity (Instance, Display_Name); if Entity_Name /= No_Name then Add_Str_To_Name_Buffer ("_"); Get_Name_String_And_Append (Entity_Name); end if; Full_Name := Name_Find; end case; return Full_Name; end Compute_Full_Name_Of_Instance; end Ocarina.Nutils;