|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- L I B . U T I L --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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;
|
