OpenAADL / ocarina
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 _ C . R U N T I M E      --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--               Copyright (C) 2008-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 Utils; use Utils;
37

38
with Charset;       use Charset;
39
with Ocarina.Namet; use Ocarina.Namet;
40

41
with Ocarina.Backends.C_Tree.Nodes;
42
with Ocarina.Backends.C_Tree.Nutils;
43

44 1
package body Ocarina.Backends.PO_HI_C.Runtime is
45

46
   use Ocarina.Backends.C_Tree.Nodes;
47
   use Ocarina.Backends.C_Tree.Nutils;
48

49
   Initialized : Boolean := False;
50

51
   RED : array (RE_Id) of Node_Id := (RE_Id'Range => No_Node);
52
   RHD : array (RH_Id) of Node_Id := (RH_Id'Range => No_Node);
53

54
   --  Arrays of run-time entity and unit 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
   ------------------------
72
   -- Apply_Casing_Rules --
73
   ------------------------
74

75 1
   procedure Apply_Casing_Rules (S : in out String) is
76 1
      New_Word : Boolean         := True;
77 1
      Length   : Natural         := S'Length;
78 1
      S1       : constant String := To_Lower (S);
79
   begin
80 1
      GNAT.Case_Util.To_Mixed (S);
81

82 1
      for I in S'Range loop
83 1
         if New_Word then
84 1
            New_Word := False;
85 1
            for J in 1 .. Rules_Last loop
86 1
               if Rules (J).Size <= Length
87 1
                 and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all
88
               then
89 1
                  S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all;
90
               end if;
91 1
            end loop;
92
         end if;
93 1
         if S (I) = '_' then
94 1
            New_Word := True;
95 1
            for J in 1 .. Rules_Last loop
96 1
               if Rules (J).Size <= Length
97 1
                 and then S1 (I .. I + Rules (J).Size - 1) = Rules (J).From.all
98
               then
99 0
                  S (I .. I + Rules (J).Size - 1) := Rules (J).Into.all;
100
               end if;
101 1
            end loop;
102
         end if;
103 1
         Length := Length - 1;
104 1
      end loop;
105 1
   end Apply_Casing_Rules;
106

107
   ----------------
108
   -- Initialize --
109
   ----------------
110

111 1
   procedure Initialize is
112 1
      Name  : Name_Id;
113 1
      N     : Node_Id;
114 1
      Local : Boolean;
115
   begin
116
      --  Initialize the runtime only once
117

118 1
      if Initialized then
119 0
         return;
120
      end if;
121

122 1
      Initialized := True;
123 1
      Local       := False;
124

125 1
      Register_Casing_Rule ("AADL");
126 1
      Register_Casing_Rule ("char_array");
127 1
      Register_Casing_Rule ("nul");
128

129 1
      for E in RF_Id loop
130 1
         Set_Str_To_Name_Buffer (RE_Id'Image (E));
131 1
         Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len));
132

133 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
134

135 1
         while Name_Buffer (Name_Len) = '_' loop
136 0
            Name_Len := Name_Len - 1;
137 0
         end loop;
138

139 1
         Name := Name_Find;
140

141 1
         Name    := Utils.To_Lower (Name);
142 1
         RED (E) := New_Node (K_Defining_Identifier);
143 1
         Set_Name (RED (E), Name);
144 1
      end loop;
145

146 1
      for E in RB_Id loop
147 1
         Set_Str_To_Name_Buffer (RB_Id'Image (E));
148 1
         Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len));
149

150 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
151

152 1
         while Name_Buffer (Name_Len) in '0' .. '9'
153 1
           or else Name_Buffer (Name_Len) = '_'
154
         loop
155 0
            Name_Len := Name_Len - 1;
156 0
         end loop;
157

158 1
         Name := Name_Find;
159

160 1
         Name    := To_Lower (Name);
161 1
         RED (E) := New_Node (K_Defining_Identifier);
162 1
         Set_Name (RED (E), Name);
163 1
      end loop;
164

165 1
      for E in RM_Id loop
166 1
         Set_Str_To_Name_Buffer (RM_Id'Image (E));
167 1
         Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len));
168 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
169

170 1
         while Name_Buffer (Name_Len) in '0' .. '9'
171 1
           or else Name_Buffer (Name_Len) = '_'
172
         loop
173 0
            Name_Len := Name_Len - 1;
174 0
         end loop;
175

176 1
         Name := Name_Find;
177

178 1
         Name    := To_Upper (Name);
179 1
         RED (E) := New_Node (K_Defining_Identifier);
180 1
         Set_Name (RED (E), Name);
181 1
      end loop;
182

183 1
      for E in RH_Id loop
184 1
         Set_Str_To_Name_Buffer (RH_Id'Image (E));
185 1
         Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len));
186 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
187

188 1
         while Name_Buffer (Name_Len) = '_' loop
189 0
            Name_Len := Name_Len - 1;
190 0
         end loop;
191

192 1
         Name := Name_Find;
193

194 1
         Name := Utils.To_Lower (Name);
195 1
         N    := New_Node (K_Defining_Identifier);
196 1
         Set_Name (N, Name);
197

198 1
         Local := E = RH_Subprograms;
199

200 1
         RHD (E) := Make_Include_Clause (N, Local);
201 1
      end loop;
202

203 1
      for E in RC_Id loop
204 1
         Set_Str_To_Name_Buffer (RC_Id'Image (E));
205 1
         Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len));
206 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
207

208 1
         while Name_Buffer (Name_Len) in '0' .. '9'
209 1
           or else Name_Buffer (Name_Len) = '_'
210
         loop
211 0
            Name_Len := Name_Len - 1;
212 0
         end loop;
213

214 1
         Name := Name_Find;
215

216 1
         Name    := To_Upper (Name);
217 1
         RED (E) := New_Node (K_Defining_Identifier);
218 1
         Set_Name (RED (E), Name);
219 1
      end loop;
220

221 1
      for E in RT_Id loop
222 1
         Set_Str_To_Name_Buffer (RT_Id'Image (E));
223 1
         Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len));
224 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
225

226 1
         while Name_Buffer (Name_Len) in '0' .. '9'
227 1
           or else Name_Buffer (Name_Len) = '_'
228
         loop
229 0
            Name_Len := Name_Len - 1;
230 0
         end loop;
231

232 1
         Name := Name_Find;
233

234 1
         Name    := To_Lower (Name);
235 1
         RED (E) := New_Node (K_Defining_Identifier);
236 1
         Set_Name (RED (E), Name);
237 1
      end loop;
238

239 1
      for E in RV_Id loop
240 1
         Set_Str_To_Name_Buffer (RV_Id'Image (E));
241 1
         Set_Str_To_Name_Buffer ("__po_hi_" & Name_Buffer (4 .. Name_Len));
242 1
         Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));
243

244 1
         while Name_Buffer (Name_Len) in '0' .. '9'
245 1
           or else Name_Buffer (Name_Len) = '_'
246
         loop
247 0
            Name_Len := Name_Len - 1;
248 0
         end loop;
249

250 1
         Name := Name_Find;
251

252 1
         Name    := To_Lower (Name);
253 1
         RED (E) := New_Node (K_Defining_Identifier);
254 1
         Set_Name (RED (E), Name);
255 1
      end loop;
256
   end Initialize;
257

258
   -----------
259
   -- Reset --
260
   -----------
261

262 1
   procedure Reset is
263
   begin
264 1
      RED        := (RE_Id'Range => No_Node);
265 1
      RHD        := (RH_Id'Range => No_Node);
266 1
      Rules_Last := 0;
267

268 1
      Initialized := False;
269 1
   end Reset;
270

271
   --------
272
   -- RE --
273
   --------
274

275 1
   function RE (Id : RE_Id) return Node_Id is
276
   begin
277 1
      if RE_Header_Table (Id) /= RH_Null then
278 1
         Add_Include (RH (RE_Header_Table (Id)));
279
      end if;
280 1
      return Copy_Node (RED (Id));
281
   end RE;
282

283
   --------
284
   -- RH --
285
   --------
286

287 1
   function RH (Id : RH_Id) return Node_Id is
288
   begin
289 1
      return Copy_Node (RHD (Id));
290
   end RH;
291

292
   --------------------------
293
   -- Register_Casing_Rule --
294
   --------------------------
295

296 1
   procedure Register_Casing_Rule (S : String) is
297
   begin
298 1
      Rules_Last              := Rules_Last + 1;
299 1
      Rules (Rules_Last).Size := S'Length;
300 1
      Rules (Rules_Last).Into := new String'(S);
301 1
      Rules (Rules_Last).From := new String'(S);
302 1
      To_Lower (Rules (Rules_Last).From.all);
303 1
   end Register_Casing_Rule;
304

305 1
end Ocarina.Backends.PO_HI_C.Runtime;

Read our documentation on viewing source code .

Loading