--------------------------------------------------- ----------------------------- -- -- -- 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;