1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 package body Output is
34 Buffer : String (1 .. Buffer_Max + 1) := (others => '*');
35 for Buffer'Alignment use 4;
36 -- Buffer used to build output line. We do line buffering because it is
37 -- needed for the support of the debug-generated-code option (-gnatD). Note
38 -- any attempt to write more output to a line than can fit in the buffer
39 -- will be silently ignored. The alignment clause improves the efficiency
40 -- of the save/restore procedures.
42 Next_Col : Positive range 1 .. Buffer'Length + 1 := 1;
43 -- Column about to be written
45 Current_FD : File_Descriptor := Standout;
46 -- File descriptor for current output
48 Special_Output_Proc : Output_Proc := null;
49 -- Record argument to last call to Set_Special_Output. If this is
50 -- non-null, then we are in special output mode.
52 Indentation_Amount : constant Positive := 3;
53 -- Number of spaces to output for each indentation level
55 Indentation_Limit : constant Positive := 40;
56 -- Indentation beyond this number of spaces wraps around
58 pragma Assert (Indentation_Limit < Buffer_Max / 2);
59 -- Make sure this is substantially shorter than the line length
61 Cur_Indentation : Natural := 0;
62 -- Number of spaces to indent each line
64 -----------------------
65 -- Local_Subprograms --
66 -----------------------
68 procedure Flush_Buffer;
69 -- Flush buffer if non-empty and reset column counter
71 ---------------------------
72 -- Cancel_Special_Output --
73 ---------------------------
75 procedure Cancel_Special_Output is
77 Special_Output_Proc := null;
78 end Cancel_Special_Output;
84 function Column return Pos is
86 return Pos (Next_Col);
89 ----------------------
90 -- Delete_Last_Char --
91 ----------------------
93 procedure Delete_Last_Char is
96 Next_Col := Next_Col - 1;
104 procedure Flush_Buffer is
105 Write_Error : exception;
106 -- Raised if Write fails
112 procedure Write_Buffer (Buf : String);
113 -- Write out Buf, either using Special_Output_Proc, or the normal way
114 -- using Write. Raise Write_Error if Write fails (presumably due to disk
115 -- full). Write_Error is not used in the case of Special_Output_Proc.
117 procedure Write_Buffer (Buf : String) is
119 -- If Special_Output_Proc has been set, then use it
121 if Special_Output_Proc /= null then
122 Special_Output_Proc.all (Buf);
124 -- If output is not set, then output to either standard output
125 -- or standard error.
127 elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
133 Len : constant Natural := Next_Col - 1;
135 -- Start of processing for Flush_Buffer
140 -- If there's no indentation, or if the line is too long with
141 -- indentation, or if it's a blank line, just write the buffer.
143 if Cur_Indentation = 0
144 or else Cur_Indentation + Len > Buffer_Max
145 or else Buffer (1 .. Len) = (1 => ASCII.LF)
147 Write_Buffer (Buffer (1 .. Len));
149 -- Otherwise, construct a new buffer with preceding spaces, and
154 Indented_Buffer : constant String :=
155 (1 .. Cur_Indentation => ' ') &
158 Write_Buffer (Indented_Buffer);
165 -- If there are errors with standard error just quit. Otherwise
166 -- set the output to standard error before reporting a failure
169 if Current_FD /= Standerr then
170 Current_FD := Standerr;
172 Write_Line ("fatal error: disk full");
178 -- Buffer is now empty
188 procedure Ignore_Output (S : String) is
199 -- The "mod" in the following assignment is to cause a wrap around in
200 -- the case where there is too much indentation.
203 (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
210 function Last_Char return Character is
212 if Next_Col /= 1 then
213 return Buffer (Next_Col - 1);
225 -- The "mod" here undoes the wrap around from Indent above
228 (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
231 ---------------------------
232 -- Restore_Output_Buffer --
233 ---------------------------
235 procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
237 Next_Col := S.Next_Col;
238 Cur_Indentation := S.Cur_Indentation;
239 Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
240 end Restore_Output_Buffer;
242 ------------------------
243 -- Save_Output_Buffer --
244 ------------------------
246 function Save_Output_Buffer return Saved_Output_Buffer is
247 S : Saved_Output_Buffer;
249 S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
250 S.Next_Col := Next_Col;
251 S.Cur_Indentation := Cur_Indentation;
253 Cur_Indentation := 0;
255 end Save_Output_Buffer;
257 ------------------------
258 -- Set_Special_Output --
259 ------------------------
261 procedure Set_Special_Output (P : Output_Proc) is
263 Special_Output_Proc := P;
264 end Set_Special_Output;
270 procedure Set_Output (FD : File_Descriptor) is
272 if Special_Output_Proc = null then
279 ------------------------
280 -- Set_Standard_Error --
281 ------------------------
283 procedure Set_Standard_Error is
285 Set_Output (Standerr);
286 end Set_Standard_Error;
288 -------------------------
289 -- Set_Standard_Output --
290 -------------------------
292 procedure Set_Standard_Output is
294 Set_Output (Standout);
295 end Set_Standard_Output;
301 procedure w (C : Character) is
309 procedure w (S : String) is
315 procedure w (V : Int) is
321 procedure w (B : Boolean) is
330 procedure w (L : String; C : Character) is
337 procedure w (L : String; S : String) is
344 procedure w (L : String; V : Int) is
351 procedure w (L : String; B : Boolean) is
362 procedure Write_Char (C : Character) is
364 pragma Assert (Next_Col in Buffer'Range);
365 if Next_Col = Buffer'Length then
372 Buffer (Next_Col) := C;
373 Next_Col := Next_Col + 1;
381 procedure Write_Eol is
383 -- Remove any trailing spaces
385 while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
386 Next_Col := Next_Col - 1;
389 Buffer (Next_Col) := ASCII.LF;
390 Next_Col := Next_Col + 1;
394 ---------------------------
395 -- Write_Eol_Keep_Blanks --
396 ---------------------------
398 procedure Write_Eol_Keep_Blanks is
400 Buffer (Next_Col) := ASCII.LF;
401 Next_Col := Next_Col + 1;
403 end Write_Eol_Keep_Blanks;
405 ----------------------
406 -- Write_Erase_Char --
407 ----------------------
409 procedure Write_Erase_Char (C : Character) is
411 if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
412 Next_Col := Next_Col - 1;
414 end Write_Erase_Char;
420 procedure Write_Int (Val : Int) is
421 -- Type Int has one extra negative number (i.e. two's complement), so we
422 -- work with negative numbers here. Otherwise, negating Int'First will
425 subtype Nonpositive is Int range Int'First .. 0;
426 procedure Write_Abs (Val : Nonpositive);
427 -- Write out the absolute value of Val
429 procedure Write_Abs (Val : Nonpositive) is
432 Write_Abs (Val / 10); -- Recursively write higher digits
435 Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0')));
451 procedure Write_Line (S : String) is
461 procedure Write_Spaces (N : Nat) is
472 procedure Write_Str (S : String) is
474 for J in S'Range loop