OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [lib-util.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2009, 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 Hostparm.OpenVMS
104
        or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
105
      then
106
         Write_Info_Terminate;
107
      else
108
         --  Delete any trailing blanks
109
 
110
         while Info_Buffer_Len > 0
111
           and then Info_Buffer (Info_Buffer_Len) = ' '
112
         loop
113
            Info_Buffer_Len := Info_Buffer_Len - 1;
114
         end loop;
115
 
116
         Info_Buffer_Len := Info_Buffer_Len + 1;
117
         Info_Buffer (Info_Buffer_Len) := ASCII.LF;
118
         Info_Buffer_Col := 1;
119
      end if;
120
   end Write_Info_EOL;
121
 
122
   -------------------------
123
   -- Write_Info_Hex_Byte --
124
   -------------------------
125
 
126
   procedure Write_Info_Hex_Byte (J : Natural) is
127
      Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
128
   begin
129
      Write_Info_Char (Hexd (J / 16));
130
      Write_Info_Char (Hexd (J mod 16));
131
   end Write_Info_Hex_Byte;
132
 
133
   -------------------------
134
   -- Write_Info_Initiate --
135
   -------------------------
136
 
137
   procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
138
 
139
   --------------------
140
   -- Write_Info_Int --
141
   --------------------
142
 
143
   procedure Write_Info_Int (N : Int) is
144
   begin
145
      if N >= 0 then
146
         Write_Info_Nat (N);
147
 
148
      --  Negative numbers, use Write_Info_Uint to avoid problems with largest
149
      --  negative number.
150
 
151
      else
152
         Write_Info_Uint (UI_From_Int (N));
153
      end if;
154
   end Write_Info_Int;
155
 
156
   ---------------------
157
   -- Write_Info_Name --
158
   ---------------------
159
 
160
   procedure Write_Info_Name (Name : Name_Id) is
161
   begin
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;
167
   end Write_Info_Name;
168
 
169
   procedure Write_Info_Name (Name : File_Name_Type) is
170
   begin
171
      Write_Info_Name (Name_Id (Name));
172
   end Write_Info_Name;
173
 
174
   procedure Write_Info_Name (Name : Unit_Name_Type) is
175
   begin
176
      Write_Info_Name (Name_Id (Name));
177
   end Write_Info_Name;
178
 
179
   --------------------
180
   -- Write_Info_Nat --
181
   --------------------
182
 
183
   procedure Write_Info_Nat (N : Nat) is
184
   begin
185
      if N > 9 then
186
         Write_Info_Nat (N / 10);
187
      end if;
188
 
189
      Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
190
   end Write_Info_Nat;
191
 
192
   ---------------------
193
   -- Write_Info_Slit --
194
   ---------------------
195
 
196
   procedure Write_Info_Slit (S : String_Id) is
197
      C : Character;
198
 
199
   begin
200
      Write_Info_Str ("""");
201
 
202
      for J in 1 .. String_Length (S) loop
203
         C := Get_Character (Get_String_Char (S, J));
204
 
205
         if C in Character'Val (16#20#) .. Character'Val (16#7E#)
206
           and then C /= '{'
207
         then
208
            Write_Info_Char (C);
209
 
210
            if C = '"' then
211
               Write_Info_Char (C);
212
            end if;
213
 
214
         else
215
            Write_Info_Char ('{');
216
            Write_Info_Hex_Byte (Character'Pos (C));
217
            Write_Info_Char ('}');
218
         end if;
219
      end loop;
220
 
221
      Write_Info_Char ('"');
222
   end Write_Info_Slit;
223
 
224
   --------------------
225
   -- Write_Info_Str --
226
   --------------------
227
 
228
   procedure Write_Info_Str (Val : String) is
229
   begin
230
      Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
231
                                                                  := Val;
232
      Info_Buffer_Len := Info_Buffer_Len + Val'Length;
233
      Info_Buffer_Col := Info_Buffer_Col + Val'Length;
234
   end Write_Info_Str;
235
 
236
   --------------------
237
   -- Write_Info_Tab --
238
   --------------------
239
 
240
   procedure Write_Info_Tab (Col : Positive) is
241
      Next_Tab : Positive;
242
 
243
   begin
244
      if Col <= Info_Buffer_Col then
245
         Write_Info_Str ("  ");
246
      else
247
         loop
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;
252
         end loop;
253
 
254
         while Info_Buffer_Col < Col loop
255
            Write_Info_Char (' ');
256
         end loop;
257
      end if;
258
   end Write_Info_Tab;
259
 
260
   --------------------------
261
   -- Write_Info_Terminate --
262
   --------------------------
263
 
264
   procedure Write_Info_Terminate is
265
   begin
266
      --  Delete any trailing blanks
267
 
268
      while Info_Buffer_Len > 0
269
        and then Info_Buffer (Info_Buffer_Len) = ' '
270
      loop
271
         Info_Buffer_Len := Info_Buffer_Len - 1;
272
      end loop;
273
 
274
      --  Write_Library_Info adds the EOL
275
 
276
      Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
277
 
278
      Info_Buffer_Len := 0;
279
      Info_Buffer_Col := 1;
280
   end Write_Info_Terminate;
281
 
282
   ---------------------
283
   -- Write_Info_Uint --
284
   ---------------------
285
 
286
   procedure Write_Info_Uint (N : Uint) is
287
   begin
288
      UI_Image (N, Decimal);
289
      Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
290
   end Write_Info_Uint;
291
 
292
end Lib.Util;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.