blob: 9047690d6637a05b770d95c241e974941418134e (
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
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B . U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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 Hostparm.OpenVMS
or else 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_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;
|
