File : lib-util.adb
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-2014, 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
26 with Hostparm;
27 with Osint.C; use Osint.C;
28 with Stringt; use Stringt;
29
30 package 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 Info_Buffer_Len + Max_Line + 1 > Max_Buffer then
104 Write_Info_Terminate;
105
106 else
107 -- Delete any trailing blanks
108
109 while Info_Buffer_Len > 0
110 and then Info_Buffer (Info_Buffer_Len) = ' '
111 loop
112 Info_Buffer_Len := Info_Buffer_Len - 1;
113 end loop;
114
115 Info_Buffer_Len := Info_Buffer_Len + 1;
116 Info_Buffer (Info_Buffer_Len) := ASCII.LF;
117 Info_Buffer_Col := 1;
118 end if;
119 end Write_Info_EOL;
120
121 -------------------------
122 -- Write_Info_Hex_Byte --
123 -------------------------
124
125 procedure Write_Info_Hex_Byte (J : Natural) is
126 Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
127 begin
128 Write_Info_Char (Hexd (J / 16));
129 Write_Info_Char (Hexd (J mod 16));
130 end Write_Info_Hex_Byte;
131
132 -------------------------
133 -- Write_Info_Initiate --
134 -------------------------
135
136 procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
137
138 --------------------
139 -- Write_Info_Int --
140 --------------------
141
142 procedure Write_Info_Int (N : Int) is
143 begin
144 if N >= 0 then
145 Write_Info_Nat (N);
146
147 -- Negative numbers, use Write_Info_Uint to avoid problems with largest
148 -- negative number.
149
150 else
151 Write_Info_Uint (UI_From_Int (N));
152 end if;
153 end Write_Info_Int;
154
155 ---------------------
156 -- Write_Info_Name --
157 ---------------------
158
159 procedure Write_Info_Name (Name : Name_Id) is
160 begin
161 Get_Name_String (Name);
162 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
163 Name_Buffer (1 .. Name_Len);
164 Info_Buffer_Len := Info_Buffer_Len + Name_Len;
165 Info_Buffer_Col := Info_Buffer_Col + Name_Len;
166 end Write_Info_Name;
167
168 procedure Write_Info_Name (Name : File_Name_Type) is
169 begin
170 Write_Info_Name (Name_Id (Name));
171 end Write_Info_Name;
172
173 procedure Write_Info_Name (Name : Unit_Name_Type) is
174 begin
175 Write_Info_Name (Name_Id (Name));
176 end Write_Info_Name;
177
178 -----------------------------------
179 -- Write_Info_Name_May_Be_Quoted --
180 -----------------------------------
181
182 procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
183 Quoted : Boolean := False;
184 Cur : Positive;
185
186 begin
187 Get_Name_String (Name);
188
189 -- The file/path name is quoted only if it includes spaces
190
191 for J in 1 .. Name_Len loop
192 if Name_Buffer (J) = ' ' then
193 Quoted := True;
194 exit;
195 end if;
196 end loop;
197
198 -- Deal with quoting string if needed
199
200 if Quoted then
201 Insert_Str_In_Name_Buffer ("""", 1);
202 Add_Char_To_Name_Buffer ('"');
203
204 -- Any character '"' is doubled
205
206 Cur := 2;
207 while Cur < Name_Len loop
208 if Name_Buffer (Cur) = '"' then
209 Insert_Str_In_Name_Buffer ("""", Cur);
210 Cur := Cur + 2;
211 else
212 Cur := Cur + 1;
213 end if;
214 end loop;
215 end if;
216
217 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
218 Name_Buffer (1 .. Name_Len);
219 Info_Buffer_Len := Info_Buffer_Len + Name_Len;
220 Info_Buffer_Col := Info_Buffer_Col + Name_Len;
221 end Write_Info_Name_May_Be_Quoted;
222
223 --------------------
224 -- Write_Info_Nat --
225 --------------------
226
227 procedure Write_Info_Nat (N : Nat) is
228 begin
229 if N > 9 then
230 Write_Info_Nat (N / 10);
231 end if;
232
233 Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
234 end Write_Info_Nat;
235
236 ---------------------
237 -- Write_Info_Slit --
238 ---------------------
239
240 procedure Write_Info_Slit (S : String_Id) is
241 C : Character;
242
243 begin
244 Write_Info_Str ("""");
245
246 for J in 1 .. String_Length (S) loop
247 C := Get_Character (Get_String_Char (S, J));
248
249 if C in Character'Val (16#20#) .. Character'Val (16#7E#)
250 and then C /= '{'
251 then
252 Write_Info_Char (C);
253
254 if C = '"' then
255 Write_Info_Char (C);
256 end if;
257
258 else
259 Write_Info_Char ('{');
260 Write_Info_Hex_Byte (Character'Pos (C));
261 Write_Info_Char ('}');
262 end if;
263 end loop;
264
265 Write_Info_Char ('"');
266 end Write_Info_Slit;
267
268 --------------------
269 -- Write_Info_Str --
270 --------------------
271
272 procedure Write_Info_Str (Val : String) is
273 begin
274 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
275 := Val;
276 Info_Buffer_Len := Info_Buffer_Len + Val'Length;
277 Info_Buffer_Col := Info_Buffer_Col + Val'Length;
278 end Write_Info_Str;
279
280 --------------------
281 -- Write_Info_Tab --
282 --------------------
283
284 procedure Write_Info_Tab (Col : Positive) is
285 Next_Tab : Positive;
286
287 begin
288 if Col <= Info_Buffer_Col then
289 Write_Info_Str (" ");
290 else
291 loop
292 Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
293 exit when Col < Next_Tab;
294 Write_Info_Char (ASCII.HT);
295 Info_Buffer_Col := Next_Tab;
296 end loop;
297
298 while Info_Buffer_Col < Col loop
299 Write_Info_Char (' ');
300 end loop;
301 end if;
302 end Write_Info_Tab;
303
304 --------------------------
305 -- Write_Info_Terminate --
306 --------------------------
307
308 procedure Write_Info_Terminate is
309 begin
310 -- Delete any trailing blanks
311
312 while Info_Buffer_Len > 0
313 and then Info_Buffer (Info_Buffer_Len) = ' '
314 loop
315 Info_Buffer_Len := Info_Buffer_Len - 1;
316 end loop;
317
318 -- Write_Library_Info adds the EOL
319
320 Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
321
322 Info_Buffer_Len := 0;
323 Info_Buffer_Col := 1;
324 end Write_Info_Terminate;
325
326 ---------------------
327 -- Write_Info_Uint --
328 ---------------------
329
330 procedure Write_Info_Uint (N : Uint) is
331 begin
332 UI_Image (N, Decimal);
333 Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
334 end Write_Info_Uint;
335
336 end Lib.Util;