--------------------------------------------------- ----------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- G A I A . P R O C E S S O R . N O D E S . U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, 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; use Namet; with Ocarina.Nodes; with Ocarina.Entities; with Gaia.Utils; package body Gaia.Processor.Nodes.Utils is package ON renames Ocarina.Nodes; package GN renames Gaia.Processor.Nodes; function Build_Package_Name (Name : Name_Id) return List_Id; -- Internal function useful to build namespace scoped names ----------------------- -- 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; -------------- -- New_List -- -------------- function New_List (Kind : Node_Kind) return List_Id is begin return List_Id (New_Node (Kind)); end New_List; -------------- -- 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; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind) return Node_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); return N; end New_Node; -------------------------------- -- 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; -------------------------- -- Build_Namespace_Name -- -------------------------- function Build_Namespace_Name (Namespace : Node_Id) return Name_Id is pragma Assert (Namespace /= No_Node and then Kind (Namespace) = K_Namespace); Name : constant Name_Id := Gaia.Processor.Nodes.Name (Identifier (Namespace)); begin Get_Name_String (Partition_Name); if Name /= No_Name then Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Name); end if; return Name_Find; end Build_Namespace_Name; ------------------------ -- Build_Package_Name -- ------------------------ function Build_Package_Name (S : Node_Id) return Name_Id is pragma Assert (No (S) or else Kind (S) = K_Scoped_Name); Name : Name_Id := No_Name; begin if Present (S) then Name := Gaia_Fully_Qualified_Name (S, "."); end if; Get_Name_String (Partition_Name); if Name /= No_Name then Add_Char_To_Name_Buffer ('.'); Get_Name_String_And_Append (Name); end if; return Name_Find; end Build_Package_Name; ------------------------ -- Build_Package_Name -- ------------------------ function Build_Package_Name (Name : Name_Id) return List_Id is use ON; Package_Name_List : List_Id; begin if Name = No_Name then Package_Name_List := No_List; else Get_Name_String (Name); -- To get uniform case handling of the separation between -- names and the end of the full name Add_Char_To_Name_Buffer (':'); declare List_Node : Node_Id; Package_Name : constant String := Name_Buffer (Name_Buffer'First .. Name_Len); Lower_Index, Upper_Index : Natural := Package_Name'First; Identifier : Node_Id; begin Package_Name_List := New_List (GN.K_List_Id); 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 List_Node := New_Node (GN.K_Package_Name_Element); Set_Str_To_Name_Buffer (Package_Name (Lower_Index .. Upper_Index - 1)); Identifier := Make_Identifier (Name_Find); Bind_Identifier_To_Entity (Identifier, List_Node); Append_Node_To_List (List_Node, Package_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 Package_Name_List; end Build_Package_Name; --------------------- -- Make_Identifier -- --------------------- function Make_Identifier (Name : Name_Id) return Node_Id is I : constant Node_Id := New_Node (K_Identifier); begin Set_Name (I, Name); return I; end Make_Identifier; ------------------------------- -- Bind_Identifier_To_Entity -- ------------------------------- procedure Bind_Identifier_To_Entity (I : Node_Id; E : Node_Id) is begin Set_Identifier (E, I); Set_Corresponding_Entity (I, E); end Bind_Identifier_To_Entity; --------------------- -- Map_Scoped_Name -- --------------------- function Map_Scoped_Name (Referenced, AADL_Instance : Node_Id; Rewind : Boolean := True) return Node_Id is use ON; use Ocarina.Entities; Scoped : Node_Id; Identifier : Node_Id; Entity_Name : Name_Id; Parent_Scoped : Node_Id; begin if AADL_Instance = No_Node then return No_Node; end if; case ON.Kind (AADL_Instance) is when ON.K_Component_Instance => if ON.Parent_Subcomponent (AADL_Instance) /= No_Node and then Rewind then Scoped := Map_Scoped_Name (Referenced, ON.Parent_Subcomponent (AADL_Instance)); else if not Rewind then Scoped := New_Node (K_Scoped_Name); Identifier := Make_Identifier (Normalize_Name (Get_Name_Of_Entity (AADL_Instance, False))); Bind_Identifier_To_Entity (Identifier, Scoped); Parent_Scoped := Map_Namespace_Scoped_Name (Referenced, ON.Namespace (ON.Corresponding_Declaration (AADL_Instance))); Set_Parent_Scoped_Name (Scoped, Parent_Scoped); else Scoped := New_Node (K_Scoped_Name); Identifier := Make_Identifier (Normalize_Name (Get_Name_Of_Entity (AADL_Instance))); Bind_Identifier_To_Entity (Identifier, Scoped); Set_Parent_Scoped_Name (Scoped, No_Node); end if; end if; when ON.K_Call_Instance => Scoped := New_Node (K_Scoped_Name); Identifier := Make_Identifier (Normalize_Name (Get_Name_Of_Entity (AADL_Instance, False))); Bind_Identifier_To_Entity (Identifier, Scoped); Parent_Scoped := Map_Scoped_Name (Referenced, ON.Parent_Sequence (AADL_Instance)); Set_Parent_Scoped_Name (Scoped, Parent_Scoped); when others => if Rewind then Scoped := New_Node (K_Scoped_Name); Entity_Name := Normalize_Name (Get_Name_Of_Entity (AADL_Instance, False)); Parent_Scoped := Map_Scoped_Name (Referenced, ON.Parent_Component (AADL_Instance)); Set_Parent_Scoped_Name (Scoped, Parent_Scoped); Identifier := Make_Identifier (Entity_Name); Bind_Identifier_To_Entity (Identifier, Scoped); else Scoped := New_Node (K_Scoped_Name); Entity_Name := Normalize_Name (Get_Name_Of_Entity (AADL_Instance, False)); Set_Parent_Scoped_Name (Scoped, No_Node); Identifier := Make_Identifier (Entity_Name); Bind_Identifier_To_Entity (Identifier, Scoped); end if; end case; Set_Reference (Scoped, Referenced); return Scoped; end Map_Scoped_Name; ------------------------------- -- Map_Namespace_Scoped_Name -- ------------------------------- function Map_Namespace_Scoped_Name (Referenced : Node_Id; Namespace : Node_Id) return Node_Id is use Ocarina.Entities; Scoped : Node_Id := No_Node; Parent : Node_Id := No_Node; Identifier : Node_Id; P : Node_Id; Package_List : constant List_Id := Build_Package_Name (Get_Name_Of_Entity (Namespace)); begin if Is_Empty (Package_List) then return No_Node; else P := First_Node (Package_List); while Present (P) loop Parent := Scoped; Scoped := New_Node (K_Scoped_Name); Identifier := Make_Identifier (GN.Name (GN.Identifier (P))); Bind_Identifier_To_Entity (Identifier, Scoped); Set_Parent_Scoped_Name (Scoped, Parent); P := Next_Node (P); end loop; end if; Set_Reference (Scoped, Referenced); return Scoped; end Map_Namespace_Scoped_Name; ------------------------ -- Append_Scoped_Name -- ------------------------ function Append_Scoped_Name (Scoped, Referenced : Node_Id; Ident_Name : Name_Id) return Node_Id is use ON; use Ocarina.Entities; pragma Assert (Scoped = No_Node or else GN.Kind (Scoped) = GN.K_Scoped_Name); Scope : Node_Id; Identifier : Node_Id; begin Scope := New_Node (K_Scoped_Name); Identifier := Make_Identifier (Ident_Name); Bind_Identifier_To_Entity (Identifier, Scope); Set_Parent_Scoped_Name (Scope, Scoped); Set_Reference (Scope, Referenced); return Scope; end Append_Scoped_Name; ------------------------------- -- Gaia_Fully_Qualified_Name -- ------------------------------- function Gaia_Fully_Qualified_Name (S : Node_Id; Separator : String := "_") return Name_Id is pragma Assert (Kind (S) = K_Scoped_Name); procedure Add_Full_Name_To_Name_Buffer (N : Node_Id); ---------------------------------- -- Add_Full_Name_To_Name_Buffer -- ---------------------------------- procedure Add_Full_Name_To_Name_Buffer (N : Node_Id) is P : constant Node_Id := Parent_Scoped_Name (N); begin if Present (P) then Add_Full_Name_To_Name_Buffer (P); Add_Str_To_Name_Buffer (Separator); end if; if Name (Identifier (N)) /= No_Name then Get_Name_String_And_Append (Name (Identifier (N))); end if; end Add_Full_Name_To_Name_Buffer; begin Name_Len := 0; Add_Full_Name_To_Name_Buffer (S); if Name_Buffer (1) = '_' then Set_Str_To_Name_Buffer (Name_Buffer (2 .. Name_Len)); end if; return Name_Find; end Gaia_Fully_Qualified_Name; -------------------- -- Partition_Name -- -------------------- function Partition_Name return Name_Id is begin Set_Str_To_Name_Buffer ("Partition"); return Name_Find; end Partition_Name; -------------------- -- Init_Variables -- -------------------- procedure Init_Variables is begin Sync_Update_Policy := Gaia.Utils.Get_String_Name ("synchronous_lock"); Async_Update_Policy := Gaia.Utils.Get_String_Name ("asynchronous_lock"); end Init_Variables; end Gaia.Processor.Nodes.Utils;