blob: 77b0efc5b55b30c201afc583456a046fd7ee83cf (
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
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L I B . U T I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, 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;
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.
---------------------
-- 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
procedure Write_Info_Hex_Byte (J : Natural);
-- Write single hex digit
procedure Write_Info_Hex_Byte (J : Natural) is
Hexd : constant String := "0123456789abcdef";
begin
Write_Info_Char (Hexd (J / 16 + 1));
Write_Info_Char (Hexd (J mod 16 + 1));
end Write_Info_Hex_Byte;
-- Start of processing for Write_Info_Char_Code
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_Initiate --
-------------------------
procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
---------------------
-- 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_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;
end Lib.Util;
|
