1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             L I B . U T I L                              --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Hostparm;
27with Osint.C;  use Osint.C;
28with Stringt;  use Stringt;
29
30package body Lib.Util is
31
32   Max_Line   : constant Natural := 2 * Hostparm.Max_Name_Length + 64;
33   Max_Buffer : constant Natural := 1000 * Max_Line;
34
35   Info_Buffer : String (1 .. Max_Buffer);
36   --  Info_Buffer used to prepare lines of library output
37
38   Info_Buffer_Len : Natural := 0;
39   --  Number of characters stored in Info_Buffer
40
41   Info_Buffer_Col : Natural := 1;
42   --  Column number of next character to be written.
43   --  Can be different from Info_Buffer_Len + 1 because of tab characters
44   --  written by Write_Info_Tab.
45
46   procedure Write_Info_Hex_Byte (J : Natural);
47   --  Place two hex digits representing the value J (which is in the range
48   --  0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits
49   --  are output using lower case letters.
50
51   ---------------------
52   -- Write_Info_Char --
53   ---------------------
54
55   procedure Write_Info_Char (C : Character) is
56   begin
57      Info_Buffer_Len := Info_Buffer_Len + 1;
58      Info_Buffer (Info_Buffer_Len) := C;
59      Info_Buffer_Col := Info_Buffer_Col + 1;
60   end Write_Info_Char;
61
62   --------------------------
63   -- Write_Info_Char_Code --
64   --------------------------
65
66   procedure Write_Info_Char_Code (Code : Char_Code) is
67   begin
68      --  00 .. 7F
69
70      if Code <= 16#7F# then
71         Write_Info_Char (Character'Val (Code));
72
73      --  80 .. FF
74
75      elsif Code <= 16#FF# then
76         Write_Info_Char ('U');
77         Write_Info_Hex_Byte (Natural (Code));
78
79      --  0100 .. FFFF
80
81      else
82         Write_Info_Char ('W');
83         Write_Info_Hex_Byte (Natural (Code / 256));
84         Write_Info_Hex_Byte (Natural (Code mod 256));
85      end if;
86   end Write_Info_Char_Code;
87
88   --------------------
89   -- Write_Info_Col --
90   --------------------
91
92   function Write_Info_Col return Positive is
93   begin
94      return Info_Buffer_Col;
95   end Write_Info_Col;
96
97   --------------------
98   -- Write_Info_EOL --
99   --------------------
100
101   procedure Write_Info_EOL is
102   begin
103      if Hostparm.OpenVMS
104        or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
105      then
106         Write_Info_Terminate;
107      else
108         --  Delete any trailing blanks
109
110         while Info_Buffer_Len > 0
111           and then Info_Buffer (Info_Buffer_Len) = ' '
112         loop
113            Info_Buffer_Len := Info_Buffer_Len - 1;
114         end loop;
115
116         Info_Buffer_Len := Info_Buffer_Len + 1;
117         Info_Buffer (Info_Buffer_Len) := ASCII.LF;
118         Info_Buffer_Col := 1;
119      end if;
120   end Write_Info_EOL;
121
122   -------------------------
123   -- Write_Info_Hex_Byte --
124   -------------------------
125
126   procedure Write_Info_Hex_Byte (J : Natural) is
127      Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
128   begin
129      Write_Info_Char (Hexd (J / 16));
130      Write_Info_Char (Hexd (J mod 16));
131   end Write_Info_Hex_Byte;
132
133   -------------------------
134   -- Write_Info_Initiate --
135   -------------------------
136
137   procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
138
139   --------------------
140   -- Write_Info_Int --
141   --------------------
142
143   procedure Write_Info_Int (N : Int) is
144   begin
145      if N >= 0 then
146         Write_Info_Nat (N);
147
148      --  Negative numbers, use Write_Info_Uint to avoid problems with largest
149      --  negative number.
150
151      else
152         Write_Info_Uint (UI_From_Int (N));
153      end if;
154   end Write_Info_Int;
155
156   ---------------------
157   -- Write_Info_Name --
158   ---------------------
159
160   procedure Write_Info_Name (Name : Name_Id) is
161   begin
162      Get_Name_String (Name);
163      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
164        Name_Buffer (1 .. Name_Len);
165      Info_Buffer_Len := Info_Buffer_Len + Name_Len;
166      Info_Buffer_Col := Info_Buffer_Col + Name_Len;
167   end Write_Info_Name;
168
169   procedure Write_Info_Name (Name : File_Name_Type) is
170   begin
171      Write_Info_Name (Name_Id (Name));
172   end Write_Info_Name;
173
174   procedure Write_Info_Name (Name : Unit_Name_Type) is
175   begin
176      Write_Info_Name (Name_Id (Name));
177   end Write_Info_Name;
178
179   -----------------------------------
180   -- Write_Info_Name_May_Be_Quoted --
181   -----------------------------------
182
183   procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
184      Quoted : Boolean := False;
185      Cur    : Positive;
186
187   begin
188      Get_Name_String (Name);
189
190      --  The file/path name is quoted only if it includes spaces
191
192      for J in 1 .. Name_Len loop
193         if Name_Buffer (J) = ' ' then
194            Quoted := True;
195            exit;
196         end if;
197      end loop;
198
199      --  Deal with quoting string if needed
200
201      if Quoted then
202         Insert_Str_In_Name_Buffer ("""", 1);
203         Add_Char_To_Name_Buffer ('"');
204
205         --  Any character '"' is doubled
206
207         Cur := 2;
208         while Cur < Name_Len loop
209            if Name_Buffer (Cur) = '"' then
210               Insert_Str_In_Name_Buffer ("""", Cur);
211               Cur := Cur + 2;
212            else
213               Cur := Cur + 1;
214            end if;
215         end loop;
216      end if;
217
218      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
219        Name_Buffer (1 .. Name_Len);
220      Info_Buffer_Len := Info_Buffer_Len + Name_Len;
221      Info_Buffer_Col := Info_Buffer_Col + Name_Len;
222   end Write_Info_Name_May_Be_Quoted;
223
224   --------------------
225   -- Write_Info_Nat --
226   --------------------
227
228   procedure Write_Info_Nat (N : Nat) is
229   begin
230      if N > 9 then
231         Write_Info_Nat (N / 10);
232      end if;
233
234      Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
235   end Write_Info_Nat;
236
237   ---------------------
238   -- Write_Info_Slit --
239   ---------------------
240
241   procedure Write_Info_Slit (S : String_Id) is
242      C : Character;
243
244   begin
245      Write_Info_Str ("""");
246
247      for J in 1 .. String_Length (S) loop
248         C := Get_Character (Get_String_Char (S, J));
249
250         if C in Character'Val (16#20#) .. Character'Val (16#7E#)
251           and then C /= '{'
252         then
253            Write_Info_Char (C);
254
255            if C = '"' then
256               Write_Info_Char (C);
257            end if;
258
259         else
260            Write_Info_Char ('{');
261            Write_Info_Hex_Byte (Character'Pos (C));
262            Write_Info_Char ('}');
263         end if;
264      end loop;
265
266      Write_Info_Char ('"');
267   end Write_Info_Slit;
268
269   --------------------
270   -- Write_Info_Str --
271   --------------------
272
273   procedure Write_Info_Str (Val : String) is
274   begin
275      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
276                                                                  := Val;
277      Info_Buffer_Len := Info_Buffer_Len + Val'Length;
278      Info_Buffer_Col := Info_Buffer_Col + Val'Length;
279   end Write_Info_Str;
280
281   --------------------
282   -- Write_Info_Tab --
283   --------------------
284
285   procedure Write_Info_Tab (Col : Positive) is
286      Next_Tab : Positive;
287
288   begin
289      if Col <= Info_Buffer_Col then
290         Write_Info_Str ("  ");
291      else
292         loop
293            Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
294            exit when Col < Next_Tab;
295            Write_Info_Char (ASCII.HT);
296            Info_Buffer_Col := Next_Tab;
297         end loop;
298
299         while Info_Buffer_Col < Col loop
300            Write_Info_Char (' ');
301         end loop;
302      end if;
303   end Write_Info_Tab;
304
305   --------------------------
306   -- Write_Info_Terminate --
307   --------------------------
308
309   procedure Write_Info_Terminate is
310   begin
311      --  Delete any trailing blanks
312
313      while Info_Buffer_Len > 0
314        and then Info_Buffer (Info_Buffer_Len) = ' '
315      loop
316         Info_Buffer_Len := Info_Buffer_Len - 1;
317      end loop;
318
319      --  Write_Library_Info adds the EOL
320
321      Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
322
323      Info_Buffer_Len := 0;
324      Info_Buffer_Col := 1;
325   end Write_Info_Terminate;
326
327   ---------------------
328   -- Write_Info_Uint --
329   ---------------------
330
331   procedure Write_Info_Uint (N : Uint) is
332   begin
333      UI_Image (N, Decimal);
334      Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
335   end Write_Info_Uint;
336
337end Lib.Util;
338