2015-05-12 Robert Dewar <dewar@adacore.com>
[official-gcc.git] / gcc / ada / output.adb
blob0a739370ae0d511334bd77d072239fb1864ed5fd
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- O U T P U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, 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. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 package body Output is
34 Current_FD : File_Descriptor := Standout;
35 -- File descriptor for current output
37 Special_Output_Proc : Output_Proc := null;
38 -- Record argument to last call to Set_Special_Output. If this is
39 -- non-null, then we are in special output mode.
41 Indentation_Amount : constant Positive := 3;
42 -- Number of spaces to output for each indentation level
44 Indentation_Limit : constant Positive := 40;
45 -- Indentation beyond this number of spaces wraps around
47 pragma Assert (Indentation_Limit < Buffer_Max / 2);
48 -- Make sure this is substantially shorter than the line length
50 Cur_Indentation : Natural := 0;
51 -- Number of spaces to indent each line
53 -----------------------
54 -- Local_Subprograms --
55 -----------------------
57 procedure Flush_Buffer;
58 -- Flush buffer if non-empty and reset column counter
60 ---------------------------
61 -- Cancel_Special_Output --
62 ---------------------------
64 procedure Cancel_Special_Output is
65 begin
66 Special_Output_Proc := null;
67 end Cancel_Special_Output;
69 ------------
70 -- Column --
71 ------------
73 function Column return Pos is
74 begin
75 return Pos (Next_Col);
76 end Column;
78 ----------------------
79 -- Delete_Last_Char --
80 ----------------------
82 procedure Delete_Last_Char is
83 begin
84 if Next_Col /= 1 then
85 Next_Col := Next_Col - 1;
86 end if;
87 end Delete_Last_Char;
89 ------------------
90 -- Flush_Buffer --
91 ------------------
93 procedure Flush_Buffer is
94 Write_Error : exception;
95 -- Raised if Write fails
97 ------------------
98 -- Write_Buffer --
99 ------------------
101 procedure Write_Buffer (Buf : String);
102 -- Write out Buf, either using Special_Output_Proc, or the normal way
103 -- using Write. Raise Write_Error if Write fails (presumably due to disk
104 -- full). Write_Error is not used in the case of Special_Output_Proc.
106 procedure Write_Buffer (Buf : String) is
107 begin
108 -- If Special_Output_Proc has been set, then use it
110 if Special_Output_Proc /= null then
111 Special_Output_Proc.all (Buf);
113 -- If output is not set, then output to either standard output
114 -- or standard error.
116 elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
117 raise Write_Error;
119 end if;
120 end Write_Buffer;
122 Len : constant Natural := Next_Col - 1;
124 -- Start of processing for Flush_Buffer
126 begin
127 if Len /= 0 then
128 begin
129 -- If there's no indentation, or if the line is too long with
130 -- indentation, or if it's a blank line, just write the buffer.
132 if Cur_Indentation = 0
133 or else Cur_Indentation + Len > Buffer_Max
134 or else Buffer (1 .. Len) = (1 => ASCII.LF)
135 then
136 Write_Buffer (Buffer (1 .. Len));
138 -- Otherwise, construct a new buffer with preceding spaces, and
139 -- write that.
141 else
142 declare
143 Indented_Buffer : constant String :=
144 (1 .. Cur_Indentation => ' ') &
145 Buffer (1 .. Len);
146 begin
147 Write_Buffer (Indented_Buffer);
148 end;
149 end if;
151 exception
152 when Write_Error =>
154 -- If there are errors with standard error just quit. Otherwise
155 -- set the output to standard error before reporting a failure
156 -- and quitting.
158 if Current_FD /= Standerr then
159 Current_FD := Standerr;
160 Next_Col := 1;
161 Write_Line ("fatal error: disk full");
162 end if;
164 OS_Exit (2);
165 end;
167 -- Buffer is now empty
169 Next_Col := 1;
170 end if;
171 end Flush_Buffer;
173 -------------------
174 -- Ignore_Output --
175 -------------------
177 procedure Ignore_Output (S : String) is
178 begin
179 null;
180 end Ignore_Output;
182 ------------
183 -- Indent --
184 ------------
186 procedure Indent is
187 begin
188 -- The "mod" in the following assignment is to cause a wrap around in
189 -- the case where there is too much indentation.
191 Cur_Indentation :=
192 (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
193 end Indent;
195 ---------------
196 -- Last_Char --
197 ---------------
199 function Last_Char return Character is
200 begin
201 if Next_Col /= 1 then
202 return Buffer (Next_Col - 1);
203 else
204 return ASCII.NUL;
205 end if;
206 end Last_Char;
208 -------------
209 -- Outdent --
210 -------------
212 procedure Outdent is
213 begin
214 -- The "mod" here undoes the wrap around from Indent above
216 Cur_Indentation :=
217 (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
218 end Outdent;
220 ---------------------------
221 -- Restore_Output_Buffer --
222 ---------------------------
224 procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
225 begin
226 Next_Col := S.Next_Col;
227 Cur_Indentation := S.Cur_Indentation;
228 Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
229 end Restore_Output_Buffer;
231 ------------------------
232 -- Save_Output_Buffer --
233 ------------------------
235 function Save_Output_Buffer return Saved_Output_Buffer is
236 S : Saved_Output_Buffer;
237 begin
238 S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
239 S.Next_Col := Next_Col;
240 S.Cur_Indentation := Cur_Indentation;
241 Next_Col := 1;
242 Cur_Indentation := 0;
243 return S;
244 end Save_Output_Buffer;
246 ------------------------
247 -- Set_Special_Output --
248 ------------------------
250 procedure Set_Special_Output (P : Output_Proc) is
251 begin
252 Special_Output_Proc := P;
253 end Set_Special_Output;
255 ----------------
256 -- Set_Output --
257 ----------------
259 procedure Set_Output (FD : File_Descriptor) is
260 begin
261 if Special_Output_Proc = null then
262 Flush_Buffer;
263 end if;
265 Current_FD := FD;
266 end Set_Output;
268 ------------------------
269 -- Set_Standard_Error --
270 ------------------------
272 procedure Set_Standard_Error is
273 begin
274 Set_Output (Standerr);
275 end Set_Standard_Error;
277 -------------------------
278 -- Set_Standard_Output --
279 -------------------------
281 procedure Set_Standard_Output is
282 begin
283 Set_Output (Standout);
284 end Set_Standard_Output;
286 -------
287 -- w --
288 -------
290 procedure w (C : Character) is
291 begin
292 Write_Char (''');
293 Write_Char (C);
294 Write_Char (''');
295 Write_Eol;
296 end w;
298 procedure w (S : String) is
299 begin
300 Write_Str (S);
301 Write_Eol;
302 end w;
304 procedure w (V : Int) is
305 begin
306 Write_Int (V);
307 Write_Eol;
308 end w;
310 procedure w (B : Boolean) is
311 begin
312 if B then
313 w ("True");
314 else
315 w ("False");
316 end if;
317 end w;
319 procedure w (L : String; C : Character) is
320 begin
321 Write_Str (L);
322 Write_Char (' ');
323 w (C);
324 end w;
326 procedure w (L : String; S : String) is
327 begin
328 Write_Str (L);
329 Write_Char (' ');
330 w (S);
331 end w;
333 procedure w (L : String; V : Int) is
334 begin
335 Write_Str (L);
336 Write_Char (' ');
337 w (V);
338 end w;
340 procedure w (L : String; B : Boolean) is
341 begin
342 Write_Str (L);
343 Write_Char (' ');
344 w (B);
345 end w;
347 ----------------
348 -- Write_Char --
349 ----------------
351 procedure Write_Char (C : Character) is
352 begin
353 if Next_Col = Buffer'Length then
354 Write_Eol;
355 end if;
357 if C = ASCII.LF then
358 Write_Eol;
359 else
360 Buffer (Next_Col) := C;
361 Next_Col := Next_Col + 1;
362 end if;
363 end Write_Char;
365 ---------------
366 -- Write_Eol --
367 ---------------
369 procedure Write_Eol is
370 begin
371 -- Remove any trailing spaces
373 while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
374 Next_Col := Next_Col - 1;
375 end loop;
377 Buffer (Next_Col) := ASCII.LF;
378 Next_Col := Next_Col + 1;
379 Flush_Buffer;
380 end Write_Eol;
382 ---------------------------
383 -- Write_Eol_Keep_Blanks --
384 ---------------------------
386 procedure Write_Eol_Keep_Blanks is
387 begin
388 Buffer (Next_Col) := ASCII.LF;
389 Next_Col := Next_Col + 1;
390 Flush_Buffer;
391 end Write_Eol_Keep_Blanks;
393 ----------------------
394 -- Write_Erase_Char --
395 ----------------------
397 procedure Write_Erase_Char (C : Character) is
398 begin
399 if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
400 Next_Col := Next_Col - 1;
401 end if;
402 end Write_Erase_Char;
404 ---------------
405 -- Write_Int --
406 ---------------
408 procedure Write_Int (Val : Int) is
409 begin
410 if Val < 0 then
411 Write_Char ('-');
412 Write_Int (-Val);
414 else
415 if Val > 9 then
416 Write_Int (Val / 10);
417 end if;
419 Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
420 end if;
421 end Write_Int;
423 ----------------
424 -- Write_Line --
425 ----------------
427 procedure Write_Line (S : String) is
428 begin
429 Write_Str (S);
430 Write_Eol;
431 end Write_Line;
433 ------------------
434 -- Write_Spaces --
435 ------------------
437 procedure Write_Spaces (N : Nat) is
438 begin
439 for J in 1 .. N loop
440 Write_Char (' ');
441 end loop;
442 end Write_Spaces;
444 ---------------
445 -- Write_Str --
446 ---------------
448 procedure Write_Str (S : String) is
449 begin
450 for J in S'Range loop
451 Write_Char (S (J));
452 end loop;
453 end Write_Str;
455 end Output;