source: trunk/src/gcc/gcc/ada/output.adb@ 1392

Last change on this file since 1392 was 1392, checked in by bird, 21 years ago

This commit was generated by cvs2svn to compensate for changes in r1391,
which included commits to RCS files with non-trunk default branches.
  • Property cvs2svn:cvs-rev set to 1.1.1.2
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 8.4 KB
Line 
1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- O U T P U T --
6-- --
7-- B o d y --
8-- --
9-- --
10-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
11-- --
12-- GNAT is free software; you can redistribute it and/or modify it under --
13-- terms of the GNU General Public License as published by the Free Soft- --
14-- ware Foundation; either version 2, or (at your option) any later ver- --
15-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18-- for more details. You should have received a copy of the GNU General --
19-- Public License distributed with GNAT; see file COPYING. If not, write --
20-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21-- MA 02111-1307, USA. --
22-- --
23-- As a special exception, if other files instantiate generics from this --
24-- unit, or you link this unit with other files to produce an executable, --
25-- this unit does not by itself cause the resulting executable to be --
26-- covered by the GNU General Public License. This exception does not --
27-- however invalidate any other reasons why the executable file might be --
28-- covered by the GNU Public License. --
29-- --
30-- GNAT was originally developed by the GNAT team at New York University. --
31-- Extensive contributions were provided by Ada Core Technologies Inc. --
32-- --
33------------------------------------------------------------------------------
34
35with GNAT.OS_Lib; use GNAT.OS_Lib;
36
37package body Output is
38
39 Current_FD : File_Descriptor := Standout;
40 -- File descriptor for current output
41
42 Special_Output_Proc : Output_Proc := null;
43 -- Record argument to last call to Set_Special_Output. If this is
44 -- non-null, then we are in special output mode.
45
46 -------------------------
47 -- Line Buffer Control --
48 -------------------------
49
50 -- Note: the following buffer and column position are maintained by
51 -- the subprograms defined in this package, and are not normally
52 -- directly modified or accessed by a client. However, a client is
53 -- permitted to modify these values, using the knowledge that only
54 -- Write_Eol actually generates any output.
55
56 Buffer_Max : constant := 8192;
57 Buffer : String (1 .. Buffer_Max + 1);
58 -- Buffer used to build output line. We do line buffering because it
59 -- is needed for the support of the debug-generated-code option (-gnatD).
60 -- Historically it was first added because on VMS, line buffering is
61 -- needed with certain file formats. So in any case line buffering must
62 -- be retained for this purpose, even if other reasons disappear. Note
63 -- any attempt to write more output to a line than can fit in the buffer
64 -- will be silently ignored.
65
66 Next_Column : Pos range 1 .. Buffer'Length + 1 := 1;
67 -- Column about to be written.
68
69 -----------------------
70 -- Local_Subprograms --
71 -----------------------
72
73 procedure Flush_Buffer;
74 -- Flush buffer if non-empty and reset column counter
75
76 ---------------------------
77 -- Cancel_Special_Output --
78 ---------------------------
79
80 procedure Cancel_Special_Output is
81 begin
82 Special_Output_Proc := null;
83 end Cancel_Special_Output;
84
85 ------------------
86 -- Flush_Buffer --
87 ------------------
88
89 procedure Flush_Buffer is
90 Len : constant Natural := Natural (Next_Column - 1);
91
92 begin
93 if Len /= 0 then
94
95 -- If Special_Output_Proc has been set, then use it
96
97 if Special_Output_Proc /= null then
98 Special_Output_Proc.all (Buffer (1 .. Len));
99
100 -- If output is not set, then output to either standard output
101 -- or standard error.
102
103 elsif Len /= Write (Current_FD, Buffer'Address, Len) then
104
105 -- If there are errors with standard error, just quit
106
107 if Current_FD = Standerr then
108 OS_Exit (2);
109
110 -- Otherwise, set the output to standard error before
111 -- reporting a failure and quitting.
112
113 else
114 Current_FD := Standerr;
115 Next_Column := 1;
116 Write_Line ("fatal error: disk full");
117 OS_Exit (2);
118 end if;
119 end if;
120
121 -- Buffer is now empty
122
123 Next_Column := 1;
124 end if;
125 end Flush_Buffer;
126
127 ------------
128 -- Column --
129 ------------
130
131 function Column return Nat is
132 begin
133 return Next_Column;
134 end Column;
135
136 ------------------------
137 -- Set_Special_Output --
138 ------------------------
139
140 procedure Set_Special_Output (P : Output_Proc) is
141 begin
142 Special_Output_Proc := P;
143 end Set_Special_Output;
144
145 ------------------------
146 -- Set_Standard_Error --
147 ------------------------
148
149 procedure Set_Standard_Error is
150 begin
151 if Special_Output_Proc = null then
152 Flush_Buffer;
153 Next_Column := 1;
154 end if;
155
156 Current_FD := Standerr;
157 end Set_Standard_Error;
158
159 -------------------------
160 -- Set_Standard_Output --
161 -------------------------
162
163 procedure Set_Standard_Output is
164 begin
165 if Special_Output_Proc = null then
166 Flush_Buffer;
167 Next_Column := 1;
168 end if;
169
170 Current_FD := Standout;
171 end Set_Standard_Output;
172
173 -------
174 -- w --
175 -------
176
177 procedure w (C : Character) is
178 begin
179 Write_Char (''');
180 Write_Char (C);
181 Write_Char (''');
182 Write_Eol;
183 end w;
184
185 procedure w (S : String) is
186 begin
187 Write_Str (S);
188 Write_Eol;
189 end w;
190
191 procedure w (V : Int) is
192 begin
193 Write_Int (V);
194 Write_Eol;
195 end w;
196
197 procedure w (B : Boolean) is
198 begin
199 if B then
200 w ("True");
201 else
202 w ("False");
203 end if;
204 end w;
205
206 procedure w (L : String; C : Character) is
207 begin
208 Write_Str (L);
209 Write_Char (' ');
210 w (C);
211 end w;
212
213 procedure w (L : String; S : String) is
214 begin
215 Write_Str (L);
216 Write_Char (' ');
217 w (S);
218 end w;
219
220 procedure w (L : String; V : Int) is
221 begin
222 Write_Str (L);
223 Write_Char (' ');
224 w (V);
225 end w;
226
227 procedure w (L : String; B : Boolean) is
228 begin
229 Write_Str (L);
230 Write_Char (' ');
231 w (B);
232 end w;
233
234 ----------------
235 -- Write_Char --
236 ----------------
237
238 procedure Write_Char (C : Character) is
239 begin
240 if Next_Column < Buffer'Length then
241 Buffer (Natural (Next_Column)) := C;
242 Next_Column := Next_Column + 1;
243 end if;
244 end Write_Char;
245
246 ---------------
247 -- Write_Eol --
248 ---------------
249
250 procedure Write_Eol is
251 begin
252 Buffer (Natural (Next_Column)) := ASCII.LF;
253 Next_Column := Next_Column + 1;
254 Flush_Buffer;
255 end Write_Eol;
256
257 ---------------
258 -- Write_Int --
259 ---------------
260
261 procedure Write_Int (Val : Int) is
262 begin
263 if Val < 0 then
264 Write_Char ('-');
265 Write_Int (-Val);
266
267 else
268 if Val > 9 then
269 Write_Int (Val / 10);
270 end if;
271
272 Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
273 end if;
274 end Write_Int;
275
276 ----------------
277 -- Write_Line --
278 ----------------
279
280 procedure Write_Line (S : String) is
281 begin
282 Write_Str (S);
283 Write_Eol;
284 end Write_Line;
285
286 ---------------
287 -- Write_Str --
288 ---------------
289
290 procedure Write_Str (S : String) is
291 begin
292 for J in S'Range loop
293 Write_Char (S (J));
294 end loop;
295 end Write_Str;
296
297end Output;
Note: See TracBrowser for help on using the repository browser.