--------------------------------------- ----------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.PO_HI_ADA.RUNTIME -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, GET-Telecom Paris. -- -- -- -- Ocarina is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. Ocarina is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- -- Public License for more details. You should have received a copy of the -- -- GNU General Public License distributed with Ocarina; see file COPYING. -- -- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- Ocarina is maintained by the Ocarina team -- -- (ocarina-users@listes.enst.fr) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Case_Util; with Charset; use Charset; with Namet; use Namet; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Tree.Nutils; package body Ocarina.Generators.PO_HI_Ada.Runtime is use Ocarina.Generators.Ada_Tree.Nodes; use Ocarina.Generators.Ada_Tree.Nutils; Initialized : Boolean := False; RUD : array (ru_id) of node_id := (ru_id'range => No_Node); RED : array (re_id) of node_id := (re_id'range => No_Node); -- Arrays of run-time entity and unit designators type casing_rule is record Size : Natural; From : String_Access; Into : String_Access; end record; Rules : array (1 .. 64) of casing_rule; Rules_Last : Natural := 0; procedure Apply_Casing_Rules (S : in out String); -- Apply the registered casing rules on the string S procedure Register_Casing_Rule (S : String); -- Register a custom casing rule procedure Declare_Subunit (N : node_id); -- Declare the Unit corresponding to the node N as being nested function Get_Unit_Internal_Name (U_Name : name_id) return name_id; function Get_Unit_Position (U : name_id) return int; procedure Set_Unit_Position (U : name_id; Pos : int); -- The three routines below iensure the absence of conflict -- amongst different runtimes. The Get_Unit_Internal_Name does not -- affect globally the content of the name buffer. ---------------------------- -- Get_Unit_Internal_Name -- ---------------------------- function Get_Unit_Internal_Name (U_Name : name_id) return name_id is Old_Name_Len : constant Integer := Name_Len; Old_Name_Buffer : constant String := Name_Buffer; Result : name_id; begin Set_Str_To_Name_Buffer ("PO_HI_Ada%RU%"); Get_Name_String_And_Append (U_Name); Result := Name_Find; -- Restore the name buffer Name_Len := Old_Name_Len; Name_Buffer := Old_Name_Buffer; return Result; end Get_Unit_Internal_Name; ----------------------- -- Get_Unit_Position -- ----------------------- function Get_Unit_Position (U : name_id) return int is U_Name : constant name_id := Get_Unit_Internal_Name (U); begin return Get_Name_Table_Info (U_Name); end Get_Unit_Position; ----------------------- -- Set_Unit_Position -- ----------------------- procedure Set_Unit_Position (U : name_id; Pos : int) is U_Name : constant name_id := Get_Unit_Internal_Name (U); begin Set_Name_Table_Info (U_Name, Pos); end Set_Unit_Position; ------------------------ -- Apply_Casing_Rules -- ------------------------ procedure Apply_Casing_Rules (S : in out String) is New_Word : Boolean := True; Length : Natural := S'length; S1 : constant String := To_Lower (S); begin GNAT.Case_Util.To_Mixed (S); for I in S'range loop if New_Word then New_Word := False; for J in 1 .. Rules_Last loop if Rules (J).Size <= Length and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all then S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all; end if; end loop; end if; if S (I) = '_' then New_Word := True; for J in 1 .. Rules_Last loop if Rules (J).Size <= Length and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all then S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all; end if; end loop; end if; Length := Length - 1; end loop; end Apply_Casing_Rules; --------------------- -- Declare_Subunit -- --------------------- procedure Declare_Subunit (N : node_id) is S : node_id; begin pragma assert (Kind (N) = k_designator); S := Corresponding_Node (Defining_Identifier (N)); pragma assert (Kind (S) = k_package_specification); Set_Is_Subunit_Package (S, True); end Declare_Subunit; ---------------- -- Initialize -- ---------------- procedure Initialize is Position : Integer; Name : name_id; Identifier : node_id; Length : Natural; Pkg_Spec : node_id; begin -- Initialize the runtime only once if Initialized then return; end if; Initialized := True; Register_Casing_Rule ("AADL"); Register_Casing_Rule ("ASN1"); Register_Casing_Rule ("PolyORB_HI"); Register_Casing_Rule ("GNAT"); Register_Casing_Rule ("VM"); Register_Casing_Rule ("SOIF_MTS"); Register_Casing_Rule ("SOIF_MTS_ASSERT_V1_SPACEWIRE_PID"); Register_Casing_Rule ("SOIF_MTS_NON_GUARANTEED_DELIVERY"); Register_Casing_Rule ("char_array"); Register_Casing_Rule ("nul"); for U in ru_id'succ (ru_id'first) .. ru_id'last loop Set_Str_To_Name_Buffer (ru_id'image (U)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); RUD (U) := New_Node (k_designator); Position := 0; Name := Name_Find; Length := Name_Len; Set_Unit_Position (Name, ru_id'pos (U)); while Name_Len > 0 loop if Name_Buffer (Name_Len) = '_' then Name_Len := Name_Len - 1; Position := Integer (Get_Unit_Position (Name_Find)); exit when Position > 0; else Name_Len := Name_Len - 1; end if; end loop; -- When there is a parent, remove parent unit name from -- unit name to get real identifier. if Position > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Length)); Name := Name_Find; Set_Homogeneous_Parent_Unit_Name (RUD (U), RUD (ru_id'val (Position))); end if; Get_Name_String (Name); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); Identifier := Make_Defining_Identifier (Name_Find); Set_Defining_Identifier (RUD (U), Identifier); Pkg_Spec := New_Node (k_package_specification); Set_Is_Runtime_Package (Pkg_Spec, True); Set_Corresponding_Node (Identifier, Pkg_Spec); if Position > 0 then Set_Homogeneous_Parent_Unit_Name (Identifier, Defining_Identifier (Parent_Unit_Name (RUD (U)))); end if; end loop; -- IMPORTANT : Declare here the subunits. Example -- Declare_Subunit (RUD (RU_Subunit_To_Not_To_Be_Withed); -- Package Standard is not a subunit but it has to be handled -- in a specific way as well as subunit. Declare_Subunit (RUD (ru_standard)); for E in re_id loop Set_Str_To_Name_Buffer (re_id'image (E)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); while Name_Buffer (Name_Len) in '0' .. '9' or else Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; Name := Name_Find; RED (E) := New_Node (k_designator); Set_Defining_Identifier (RED (E), Make_Defining_Identifier (Name)); Set_Homogeneous_Parent_Unit_Name (RED (E), RUD (RE_Unit_Table (E))); end loop; end Initialize; ----------- -- Reset -- ----------- procedure Reset is begin RUD := (ru_id'range => No_Node); RED := (re_id'range => No_Node); Rules_Last := 0; Initialized := False; end Reset; -------- -- RE -- -------- function RE (Id : re_id; Withed : Boolean := True) return node_id is begin return Copy_Designator (RED (Id), Withed); end RE; -------------------------- -- Register_Casing_Rule -- -------------------------- procedure Register_Casing_Rule (S : String) is begin Rules_Last := Rules_Last + 1; Rules (Rules_Last).Size := S'length; Rules (Rules_Last).Into := new String'(S); Rules (Rules_Last).From := new String'(S); To_Lower (Rules (Rules_Last).From.all); end Register_Casing_Rule; -------- -- RU -- -------- function RU (Id : ru_id; Withed : Boolean := True) return node_id is Result : node_id; begin -- This is a runtime unit and not a runtime entity, so it's -- parent unit does not have to be "withed" Result := Copy_Designator (RUD (Id), False); if Withed then Add_With_Package (Result); end if; return Result; end RU; end Ocarina.Generators.PO_HI_Ada.Runtime;