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