------------------------------------- ----- ---------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P O _ H I _ C . R U N T I M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 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 Utils; use Utils; with Charset; use Charset; with Namet; use Namet; with Ocarina.Generators.C_Tree.Nodes; with Ocarina.Generators.C_Tree.Nutils; package body Ocarina.Generators.PO_HI_C.Runtime is use Ocarina.Generators.C_Tree.Nodes; use Ocarina.Generators.C_Tree.Nutils; Initialized : Boolean := False; RED : array (re_id) of node_id := (re_id'range => No_Node); RHD : array (rh_id) of node_id := (rh_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 ------------------------ -- 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; ---------------- -- Initialize -- ---------------- procedure Initialize is Name : name_id; begin -- Initialize the runtime only once if Initialized then return; end if; Initialized := True; Register_Casing_Rule ("AADL"); Register_Casing_Rule ("char_array"); Register_Casing_Rule ("nul"); for E in rf_id loop Set_Str_To_Name_Buffer (re_id'image (E)); Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); while Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; Name := Name_Find; Name := Utils.To_Lower (Name); RED (E) := New_Node (k_defining_identifier); Set_Name (RED (E), Name); end loop; for E in rh_id loop Set_Str_To_Name_Buffer (rh_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) = '_' loop Name_Len := Name_Len - 1; end loop; Name := Name_Find; Name := Utils.To_Lower (Name); RHD (E) := New_Node (k_defining_identifier); Set_Name (RHD (E), Name); end loop; for E in rc_id loop Set_Str_To_Name_Buffer (rc_id'image (E)); Set_Str_To_Name_Buffer ("__po_hi_" & 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; Name := To_Upper (Name); RED (E) := New_Node (k_defining_identifier); Set_Name (RED (E), Name); end loop; for E in rt_id loop Set_Str_To_Name_Buffer (rt_id'image (E)); Set_Str_To_Name_Buffer ("__po_hi_" & 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; Name := To_Lower (Name); RED (E) := New_Node (k_defining_identifier); Set_Name (RED (E), Name); end loop; for E in rv_id loop Set_Str_To_Name_Buffer (rv_id'image (E)); Set_Str_To_Name_Buffer ("__po_hi_" & 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; Name := To_Lower (Name); RED (E) := New_Node (k_defining_identifier); Set_Name (RED (E), Name); end loop; end Initialize; ----------- -- Reset -- ----------- procedure Reset is begin RED := (re_id'range => No_Node); RHD := (rh_id'range => No_Node); Rules_Last := 0; Initialized := False; end Reset; -------- -- RE -- -------- function RE (Id : re_id) return node_id is begin if RE_Header_Table (Id) /= rh_null then Add_Include (RH (RE_Header_Table (Id))); end if; return Copy_Node (RED (Id)); end RE; -------- -- RH -- -------- function RH (Id : rh_id) return node_id is begin return Copy_Node (RHD (Id)); end RH; -------------------------- -- 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; end Ocarina.Generators.PO_HI_C.Runtime;