summaryrefslogtreecommitdiff
path: root/gcc/ada/lib-util.adb
blob: 71c05ee170e39e2181c8e8abe0c7910ef89856dc (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             L I B . U T I L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Hostparm;
with Osint.C;  use Osint.C;
with Stringt;  use Stringt;

package body Lib.Util is

   Max_Line   : constant Natural := 2 * Hostparm.Max_Name_Length + 64;
   Max_Buffer : constant Natural := 1000 * Max_Line;

   Info_Buffer : String (1 .. Max_Buffer);
   --  Info_Buffer used to prepare lines of library output

   Info_Buffer_Len : Natural := 0;
   --  Number of characters stored in Info_Buffer

   Info_Buffer_Col : Natural := 1;
   --  Column number of next character to be written.
   --  Can be different from Info_Buffer_Len + 1 because of tab characters
   --  written by Write_Info_Tab.

   procedure Write_Info_Hex_Byte (J : Natural);
   --  Place two hex digits representing the value J (which is in the range
   --  0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits
   --  are output using lower case letters.

   ---------------------
   -- Write_Info_Char --
   ---------------------

   procedure Write_Info_Char (C : Character) is
   begin
      Info_Buffer_Len := Info_Buffer_Len + 1;
      Info_Buffer (Info_Buffer_Len) := C;
      Info_Buffer_Col := Info_Buffer_Col + 1;
   end Write_Info_Char;

   --------------------------
   -- Write_Info_Char_Code --
   --------------------------

   procedure Write_Info_Char_Code (Code : Char_Code) is
   begin
      --  00 .. 7F

      if Code <= 16#7F# then
         Write_Info_Char (Character'Val (Code));

      --  80 .. FF

      elsif Code <= 16#FF# then
         Write_Info_Char ('U');
         Write_Info_Hex_Byte (Natural (Code));

      --  0100 .. FFFF

      else
         Write_Info_Char ('W');
         Write_Info_Hex_Byte (Natural (Code / 256));
         Write_Info_Hex_Byte (Natural (Code mod 256));
      end if;
   end Write_Info_Char_Code;

   --------------------
   -- Write_Info_Col --
   --------------------

   function Write_Info_Col return Positive is
   begin
      return Info_Buffer_Col;
   end Write_Info_Col;

   --------------------
   -- Write_Info_EOL --
   --------------------

   procedure Write_Info_EOL is
   begin
      if Info_Buffer_Len + Max_Line + 1 > Max_Buffer then
         Write_Info_Terminate;

      else
         --  Delete any trailing blanks

         while Info_Buffer_Len > 0
           and then Info_Buffer (Info_Buffer_Len) = ' '
         loop
            Info_Buffer_Len := Info_Buffer_Len - 1;
         end loop;

         Info_Buffer_Len := Info_Buffer_Len + 1;
         Info_Buffer (Info_Buffer_Len) := ASCII.LF;
         Info_Buffer_Col := 1;
      end if;
   end Write_Info_EOL;

   -------------------------
   -- Write_Info_Hex_Byte --
   -------------------------

   procedure Write_Info_Hex_Byte (J : Natural) is
      Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
   begin
      Write_Info_Char (Hexd (J / 16));
      Write_Info_Char (Hexd (J mod 16));
   end Write_Info_Hex_Byte;

   -------------------------
   -- Write_Info_Initiate --
   -------------------------

   procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;

   --------------------
   -- Write_Info_Int --
   --------------------

   procedure Write_Info_Int (N : Int) is
   begin
      if N >= 0 then
         Write_Info_Nat (N);

      --  Negative numbers, use Write_Info_Uint to avoid problems with largest
      --  negative number.

      else
         Write_Info_Uint (UI_From_Int (N));
      end if;
   end Write_Info_Int;

   ---------------------
   -- Write_Info_Name --
   ---------------------

   procedure Write_Info_Name (Name : Name_Id) is
   begin
      Get_Name_String (Name);
      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
        Name_Buffer (1 .. Name_Len);
      Info_Buffer_Len := Info_Buffer_Len + Name_Len;
      Info_Buffer_Col := Info_Buffer_Col + Name_Len;
   end Write_Info_Name;

   procedure Write_Info_Name (Name : File_Name_Type) is
   begin
      Write_Info_Name (Name_Id (Name));
   end Write_Info_Name;

   procedure Write_Info_Name (Name : Unit_Name_Type) is
   begin
      Write_Info_Name (Name_Id (Name));
   end Write_Info_Name;

   -----------------------------------
   -- Write_Info_Name_May_Be_Quoted --
   -----------------------------------

   procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
      Quoted : Boolean := False;
      Cur    : Positive;

   begin
      Get_Name_String (Name);

      --  The file/path name is quoted only if it includes spaces

      for J in 1 .. Name_Len loop
         if Name_Buffer (J) = ' ' then
            Quoted := True;
            exit;
         end if;
      end loop;

      --  Deal with quoting string if needed

      if Quoted then
         Insert_Str_In_Name_Buffer ("""", 1);
         Add_Char_To_Name_Buffer ('"');

         --  Any character '"' is doubled

         Cur := 2;
         while Cur < Name_Len loop
            if Name_Buffer (Cur) = '"' then
               Insert_Str_In_Name_Buffer ("""", Cur);
               Cur := Cur + 2;
            else
               Cur := Cur + 1;
            end if;
         end loop;
      end if;

      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
        Name_Buffer (1 .. Name_Len);
      Info_Buffer_Len := Info_Buffer_Len + Name_Len;
      Info_Buffer_Col := Info_Buffer_Col + Name_Len;
   end Write_Info_Name_May_Be_Quoted;

   --------------------
   -- Write_Info_Nat --
   --------------------

   procedure Write_Info_Nat (N : Nat) is
   begin
      if N > 9 then
         Write_Info_Nat (N / 10);
      end if;

      Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
   end Write_Info_Nat;

   ---------------------
   -- Write_Info_Slit --
   ---------------------

   procedure Write_Info_Slit (S : String_Id) is
      C : Character;

   begin
      Write_Info_Str ("""");

      for J in 1 .. String_Length (S) loop
         C := Get_Character (Get_String_Char (S, J));

         if C in Character'Val (16#20#) .. Character'Val (16#7E#)
           and then C /= '{'
         then
            Write_Info_Char (C);

            if C = '"' then
               Write_Info_Char (C);
            end if;

         else
            Write_Info_Char ('{');
            Write_Info_Hex_Byte (Character'Pos (C));
            Write_Info_Char ('}');
         end if;
      end loop;

      Write_Info_Char ('"');
   end Write_Info_Slit;

   --------------------
   -- Write_Info_Str --
   --------------------

   procedure Write_Info_Str (Val : String) is
   begin
      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
                                                                  := Val;
      Info_Buffer_Len := Info_Buffer_Len + Val'Length;
      Info_Buffer_Col := Info_Buffer_Col + Val'Length;
   end Write_Info_Str;

   --------------------
   -- Write_Info_Tab --
   --------------------

   procedure Write_Info_Tab (Col : Positive) is
      Next_Tab : Positive;

   begin
      if Col <= Info_Buffer_Col then
         Write_Info_Str ("  ");
      else
         loop
            Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
            exit when Col < Next_Tab;
            Write_Info_Char (ASCII.HT);
            Info_Buffer_Col := Next_Tab;
         end loop;

         while Info_Buffer_Col < Col loop
            Write_Info_Char (' ');
         end loop;
      end if;
   end Write_Info_Tab;

   --------------------------
   -- Write_Info_Terminate --
   --------------------------

   procedure Write_Info_Terminate is
   begin
      --  Delete any trailing blanks

      while Info_Buffer_Len > 0
        and then Info_Buffer (Info_Buffer_Len) = ' '
      loop
         Info_Buffer_Len := Info_Buffer_Len - 1;
      end loop;

      --  Write_Library_Info adds the EOL

      Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));

      Info_Buffer_Len := 0;
      Info_Buffer_Col := 1;
   end Write_Info_Terminate;

   ---------------------
   -- Write_Info_Uint --
   ---------------------

   procedure Write_Info_Uint (N : Uint) is
   begin
      UI_Image (N, Decimal);
      Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
   end Write_Info_Uint;

end Lib.Util;