1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Osint.C; use Osint.C;
28 with Stringt; use Stringt;
30 package body Lib.Util is
32 Max_Line : constant Natural := 2 * Hostparm.Max_Name_Length + 64;
33 Max_Buffer : constant Natural := 1000 * Max_Line;
35 Info_Buffer : String (1 .. Max_Buffer);
36 -- Info_Buffer used to prepare lines of library output
38 Info_Buffer_Len : Natural := 0;
39 -- Number of characters stored in Info_Buffer
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.
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.
55 procedure Write_Info_Char (C : Character) is
57 Info_Buffer_Len := Info_Buffer_Len + 1;
58 Info_Buffer (Info_Buffer_Len) := C;
59 Info_Buffer_Col := Info_Buffer_Col + 1;
62 --------------------------
63 -- Write_Info_Char_Code --
64 --------------------------
66 procedure Write_Info_Char_Code (Code : Char_Code) is
70 if Code <= 16#7F# then
71 Write_Info_Char (Character'Val (Code));
75 elsif Code <= 16#FF# then
76 Write_Info_Char ('U');
77 Write_Info_Hex_Byte (Natural (Code));
82 Write_Info_Char ('W');
83 Write_Info_Hex_Byte (Natural (Code / 256));
84 Write_Info_Hex_Byte (Natural (Code mod 256));
86 end Write_Info_Char_Code;
92 function Write_Info_Col return Positive is
94 return Info_Buffer_Col;
101 procedure Write_Info_EOL is
104 or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
106 Write_Info_Terminate;
108 -- Delete any trailing blanks
110 while Info_Buffer_Len > 0
111 and then Info_Buffer (Info_Buffer_Len) = ' '
113 Info_Buffer_Len := Info_Buffer_Len - 1;
116 Info_Buffer_Len := Info_Buffer_Len + 1;
117 Info_Buffer (Info_Buffer_Len) := ASCII.LF;
118 Info_Buffer_Col := 1;
122 -------------------------
123 -- Write_Info_Hex_Byte --
124 -------------------------
126 procedure Write_Info_Hex_Byte (J : Natural) is
127 Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
129 Write_Info_Char (Hexd (J / 16));
130 Write_Info_Char (Hexd (J mod 16));
131 end Write_Info_Hex_Byte;
133 -------------------------
134 -- Write_Info_Initiate --
135 -------------------------
137 procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
143 procedure Write_Info_Int (N : Int) is
148 -- Negative numbers, use Write_Info_Uint to avoid problems with largest
152 Write_Info_Uint (UI_From_Int (N));
156 ---------------------
157 -- Write_Info_Name --
158 ---------------------
160 procedure Write_Info_Name (Name : Name_Id) is
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;
169 procedure Write_Info_Name (Name : File_Name_Type) is
171 Write_Info_Name (Name_Id (Name));
174 procedure Write_Info_Name (Name : Unit_Name_Type) is
176 Write_Info_Name (Name_Id (Name));
183 procedure Write_Info_Nat (N : Nat) is
186 Write_Info_Nat (N / 10);
189 Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
192 ---------------------
193 -- Write_Info_Slit --
194 ---------------------
196 procedure Write_Info_Slit (S : String_Id) is
200 Write_Info_Str ("""");
202 for J in 1 .. String_Length (S) loop
203 C := Get_Character (Get_String_Char (S, J));
205 if C in Character'Val (16#20#) .. Character'Val (16#7E#)
215 Write_Info_Char ('{');
216 Write_Info_Hex_Byte (Character'Pos (C));
217 Write_Info_Char ('}');
221 Write_Info_Char ('"');
228 procedure Write_Info_Str (Val : String) is
230 Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
232 Info_Buffer_Len := Info_Buffer_Len + Val'Length;
233 Info_Buffer_Col := Info_Buffer_Col + Val'Length;
240 procedure Write_Info_Tab (Col : Positive) is
244 if Col <= Info_Buffer_Col then
245 Write_Info_Str (" ");
248 Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
249 exit when Col < Next_Tab;
250 Write_Info_Char (ASCII.HT);
251 Info_Buffer_Col := Next_Tab;
254 while Info_Buffer_Col < Col loop
255 Write_Info_Char (' ');
260 --------------------------
261 -- Write_Info_Terminate --
262 --------------------------
264 procedure Write_Info_Terminate is
266 -- Delete any trailing blanks
268 while Info_Buffer_Len > 0
269 and then Info_Buffer (Info_Buffer_Len) = ' '
271 Info_Buffer_Len := Info_Buffer_Len - 1;
274 -- Write_Library_Info adds the EOL
276 Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
278 Info_Buffer_Len := 0;
279 Info_Buffer_Col := 1;
280 end Write_Info_Terminate;
282 ---------------------
283 -- Write_Info_Uint --
284 ---------------------
286 procedure Write_Info_Uint (N : Uint) is
288 UI_Image (N, Decimal);
289 Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));