1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--   O C A R I N A . B A C K E N D S . P O _ H I _ A D A . R U N T I M E    --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2006-2009 Telecom ParisTech,                 --
10
--                 2010-2019 ESA & ISAE, 2019-2020 OpenAADL                 --
11
--                                                                          --
12
-- Ocarina  is free software; you can redistribute it and/or modify under   --
13
-- terms of the  GNU General Public License as published  by the Free Soft- --
14
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
15
-- sion. Ocarina is distributed in the hope that it will be useful, but     --
16
-- WITHOUT ANY WARRANTY; without even the implied warranty of               --
17
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     --
18
--                                                                          --
19
-- As a special exception under Section 7 of GPL version 3, you are granted --
20
-- additional permissions described in the GCC Runtime Library Exception,   --
21
-- version 3.1, as published by the Free Software Foundation.               --
22
--                                                                          --
23
-- You should have received a copy of the GNU General Public License and    --
24
-- a copy of the GCC Runtime Library Exception along with this program;     --
25
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26
-- <http://www.gnu.org/licenses/>.                                          --
27
--                                                                          --
28
--                    Ocarina is maintained by OpenAADL team                --
29
--                              (info@openaadl.org)                         --
30
--                                                                          --
31
------------------------------------------------------------------------------
32

33
with GNAT.OS_Lib; use GNAT.OS_Lib;
34
with GNAT.Case_Util;
35

36
with Charset;       use Charset;
37
with Ocarina.Namet; use Ocarina.Namet;
38

39
with Ocarina.Backends.Ada_Tree.Nodes;
40
with Ocarina.Backends.Ada_Tree.Nutils;
41

42 1
package body Ocarina.Backends.PO_HI_Ada.Runtime is
43

44
   use Ocarina.Backends.Ada_Tree.Nodes;
45
   use Ocarina.Backends.Ada_Tree.Nutils;
46

47
   Initialized : Boolean := False;
48

49
   RUD : array (RU_Id) of Node_Id := (RU_Id'Range => No_Node);
50
   RED : array (RE_Id) of Node_Id := (RE_Id'Range => No_Node);
51
   --  Arrays of runtime entity and unit designators
52

53
   REI : array (RE_Id) of Name_Id := (RE_Id'Range => No_Name);
54
   --  Arrays of custom Images for runtime entity designators
55

56
   type Casing_Rule is record
57
      Size : Natural;
58
      From : String_Access;
59
      Into : String_Access;
60
   end record;
61

62 1
   Rules      : array (1 .. 64) of Casing_Rule;
63
   Rules_Last : Natural := 0;
64

65
   procedure Apply_Casing_Rules (S : in out String);
66
   --  Apply the registered casing rules on the string S
67

68
   procedure Register_Casing_Rule (S : String);
69
   --  Register a custom casing rule
70

71
   procedure Declare_Subunit (N : Node_Id);
72
   --  Declare the Unit corresponding to the node N as being nested
73

74
   function Get_Unit_Internal_Name (U_Name : Name_Id) return Name_Id;
75
   function Get_Unit_Position (U : Name_Id) return Int;
76
   procedure Set_Unit_Position (U : Name_Id; Pos : Int);
77
   --  The three routines below iensure the absence of conflict
78
   --  amongst different runtimes. The Get_Unit_Internal_Name does not
79
   --  affect globally the content of the name buffer.
80

81
   ----------------------------
82
   -- Get_Unit_Internal_Name --
83
   ----------------------------
84

85 1
   function Get_Unit_Internal_Name (U_Name : Name_Id) return Name_Id is
86 1
      Old_Name_Len    : constant Integer := Name_Len;
87 1
      Old_Name_Buffer : constant String  := Name_Buffer;
88 1
      Result          : Name_Id;
89
   begin
90 1
      Set_Str_To_Name_Buffer ("PO_HI_Ada%RU%");
91 1
      Get_Name_String_And_Append (U_Name);
92 1
      Result := Name_Find;
93

94
      --  Restore the name buffer
95

96
      Name_Len    := Old_Name_Len;
97 1
      Name_Buffer := Old_Name_Buffer;
98

99 1
      return Result;
100 1
   end Get_Unit_Internal_Name;
101

102
   -----------------------
103
   -- Get_Unit_Position --
104
   -----------------------
105

106 1
   function Get_Unit_Position (U : Name_Id) return Int is
107 1
      U_Name : constant Name_Id := Get_Unit_Internal_Name (U);
108
   begin
109 1
      return Get_Name_Table_Info (U_Name);
110
   end Get_Unit_Position;
111

112
   -----------------------
113
   -- Set_Unit_Position --
114
   -----------------------
115

116 1
   procedure Set_Unit_Position (U : Name_Id; Pos : Int) is
117 1
      U_Name : constant Name_Id := Get_Unit_Internal_Name (U);
118
   begin
119 1
      Set_Name_Table_Info (U_Name, Pos);
120 1
   end Set_Unit_Position;
121

122
   ------------------------
123
   -- Apply_Casing_Rules --
124
   ------------------------
125

126 1
   procedure Apply_Casing_Rules (S : in out String) is
127 1
      New_Word : Boolean         := True;
128
      Length   : Natural         := S'Length;
129
      S1       : constant String := To_Lower (S);
130
   begin
131 1
      GNAT.Case_Util.To_Mixed (S);
132

133 1
      for I in S'Range loop
134 1
         if New_Word then
135 1
            New_Word := False;
136 1
            for J in 1 .. Rules_Last loop
137
               if Rules (J).Size <= Length
138
                 and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all
139
               then
140
                  S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all;
141
               end if;
142 1
            end loop;
143
         end if;
144 1
         if S (I) = '_' then
145 1
            New_Word := True;
146 1
            for J in 1 .. Rules_Last loop
147
               if Rules (J).Size <= Length
148
                 and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all
149
               then
150 0
                  S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all;
151
               end if;
152 1
            end loop;
153
         end if;
154
         Length := Length - 1;
155 1
      end loop;
156 1
   end Apply_Casing_Rules;
157

158
   ---------------------
159
   -- Declare_Subunit --
160
   ---------------------
161

162 1
   procedure Declare_Subunit (N : Node_Id) is
163 1
      S : Node_Id;
164

165
   begin
166
      pragma Assert (Kind (N) = K_Designator);
167 1
      S := Corresponding_Node (Defining_Identifier (N));
168
      pragma Assert (Kind (S) = K_Package_Specification);
169 1
      Set_Is_Subunit_Package (S, True);
170 1
   end Declare_Subunit;
171

172
   ----------------
173
   -- Initialize --
174
   ----------------
175

176 1
   procedure Initialize is
177 1
      Position   : Integer;
178 1
      Name       : Name_Id;
179 1
      Identifier : Node_Id;
180 1
      Length     : Natural;
181 1
      Pkg_Spec   : Node_Id;
182

183
   begin
184
      --  Initialize the runtime only once
185

186 1
      if Initialized then
187 0
         return;
188
      end if;
189

190 1
      Initialized := True;
191

192
      --  Register the custom casing rules
193

194 1
      Register_Casing_Rule ("AADL");
195 1
      Register_Casing_Rule ("ASN1");
196 1
      Register_Casing_Rule ("PolyORB_HI");
197 1
      Register_Casing_Rule ("GNAT");
198 1
      Register_Casing_Rule ("VM");
199 1
      Register_Casing_Rule ("char_array");
200 1
      Register_Casing_Rule ("nul");
201

202
      --  Register the custom runtime entity images
203

204 1
      REI (RE_Integer_8)   := Get_String_Name ("Integer_8");
205 1
      REI (RE_Integer_16)  := Get_String_Name ("Integer_16");
206 1
      REI (RE_Integer_32)  := Get_String_Name ("Integer_32");
207 1
      REI (RE_Integer_64)  := Get_String_Name ("Integer_64");
208 1
      REI (RE_Unsigned_8)  := Get_String_Name ("Unsigned_8");
209 1
      REI (RE_Unsigned_16) := Get_String_Name ("Unsigned_16");
210 1
      REI (RE_Unsigned_32) := Get_String_Name ("Unsigned_32");
211 1
      REI (RE_Unsigned_64) := Get_String_Name ("Unsigned_64");
212
      --  We do this because suffixes of the form _X where X is an
213
      --  integer are cut by default.
214

215 1
      for U in RU_Id'Succ (RU_Id'First) .. RU_Id'Last loop
216 1
         Set_Str_To_Name_Buffer (RU_Id'Image (U));
217
         Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len));
218

219 1
         RUD (U) := New_Node (K_Designator);
220

221 1
         Position := 0;
222 1
         Name     := Name_Find;
223 1
         Length   := Name_Len;
224 1
         Set_Unit_Position (Name, RU_Id'Pos (U));
225

226 1
         while Name_Len > 0 loop
227
            if Name_Buffer (Name_Len) = '_' then
228
               Name_Len := Name_Len - 1;
229 1
               Position := Integer (Get_Unit_Position (Name_Find));
230 1
               exit when Position > 0;
231

232
            else
233
               Name_Len := Name_Len - 1;
234
            end if;
235 1
         end loop;
236

237
         --  When there is a parent, remove parent unit name from
238
         --  unit name to get real identifier.
239

240 1
         if Position > 0 then
241
            Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Length));
242 1
            Name := Name_Find;
243 1
            Set_Homogeneous_Parent_Unit_Name
244
              (RUD (U),
245
               RUD (RU_Id'Val (Position)));
246
         end if;
247

248 1
         Get_Name_String (Name);
249
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
250 1
         Identifier := Make_Defining_Identifier (Name_Find);
251 1
         Set_Defining_Identifier (RUD (U), Identifier);
252 1
         Pkg_Spec := New_Node (K_Package_Specification);
253 1
         Set_Is_Runtime_Package (Pkg_Spec, True);
254 1
         Set_Corresponding_Node (Identifier, Pkg_Spec);
255

256 1
         if Position > 0 then
257 1
            Set_Homogeneous_Parent_Unit_Name
258
              (Identifier,
259 1
               Defining_Identifier (Parent_Unit_Name (RUD (U))));
260
         end if;
261

262 1
      end loop;
263

264
      --  IMPORTANT : Declare here the subunits. Example
265
      --    Declare_Subunit (RUD (RU_Subunit_Not_To_Be_Withed);
266 1
      Declare_Subunit
267
        (RUD (RU_Ada_Strings_Wide_Bounded_Generic_Bounded_Length));
268 1
      Declare_Subunit (RUD (RU_Ada_Strings_Bounded_Generic_Bounded_Length));
269 1
      Declare_Subunit (RUD (RU_PolyORB_HI_Hybrid_Task_Driver_Driver));
270 1
      Declare_Subunit (RUD (RU_Ada_Interrupts_Names));
271

272
      --  Package Standard is not a subunit but it has to be handled
273
      --  in a specific way as well as subunit.
274

275 1
      Declare_Subunit (RUD (RU_Standard));
276

277 1
      for E in RE_Id loop
278 1
         if REI (E) = No_Name then
279 1
            Set_Str_To_Name_Buffer (RE_Id'Image (E));
280
            Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len));
281
            Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
282

283
            while Name_Buffer (Name_Len) in '0' .. '9'
284
              or else Name_Buffer (Name_Len) = '_'
285
            loop
286
               Name_Len := Name_Len - 1;
287 1
            end loop;
288

289 1
            Name := Name_Find;
290
         else
291 1
            Name := REI (E);
292
         end if;
293

294 1
         RED (E) := New_Node (K_Designator);
295 1
         Set_Defining_Identifier (RED (E), Make_Defining_Identifier (Name));
296 1
         Set_Homogeneous_Parent_Unit_Name (RED (E), RUD (RE_Unit_Table (E)));
297 1
      end loop;
298
   end Initialize;
299

300
   -----------
301
   -- Reset --
302
   -----------
303

304 1
   procedure Reset is
305
   begin
306 1
      RUD        := (RU_Id'Range => No_Node);
307 1
      RED        := (RE_Id'Range => No_Node);
308 1
      Rules_Last := 0;
309

310 1
      Initialized := False;
311 1
   end Reset;
312

313
   --------
314
   -- RE --
315
   --------
316

317 1
   function RE (Id : RE_Id; Withed : Boolean := True) return Node_Id is
318
   begin
319 1
      return Copy_Designator (RED (Id), Withed);
320
   end RE;
321

322
   --------------------------
323
   -- Register_Casing_Rule --
324
   --------------------------
325

326
   procedure Register_Casing_Rule (S : String) is
327
   begin
328
      Rules_Last              := Rules_Last + 1;
329
      Rules (Rules_Last).Size := S'Length;
330
      Rules (Rules_Last).Into := new String'(S);
331
      Rules (Rules_Last).From := new String'(S);
332
      To_Lower (Rules (Rules_Last).From.all);
333 1
   end Register_Casing_Rule;
334

335
   --------
336
   -- RU --
337
   --------
338

339 1
   function RU
340
     (Id         : RU_Id;
341
      Withed     : Boolean := True;
342
      Elaborated : Boolean := False) return Node_Id
343
   is
344 1
      Result : Node_Id;
345
   begin
346
      --  This is a runtime unit and not a runtime entity, so it's
347
      --  parent unit does not have to be "withed"
348

349 1
      Result := Copy_Designator (RUD (Id), False);
350 1
      if Withed then
351 1
         Add_With_Package (Result, Elaborated => Elaborated);
352
      end if;
353 1
      return Result;
354
   end RU;
355

356 1
end Ocarina.Backends.PO_HI_Ada.Runtime;

Read our documentation on viewing source code .

Loading