1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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. 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 package body Output
is
28 Buffer
: String (1 .. Buffer_Max
+ 1) := (others => '*');
29 for Buffer
'Alignment use 4;
30 -- Buffer used to build output line. We do line buffering because it is
31 -- needed for the support of the debug-generated-code option (-gnatD). Note
32 -- any attempt to write more output to a line than can fit in the buffer
33 -- will be silently ignored. The alignment clause improves the efficiency
34 -- of the save/restore procedures.
36 Next_Col
: Positive range 1 .. Buffer
'Length + 1 := 1;
37 -- Column about to be written
39 Current_FD
: File_Descriptor
:= Standout
;
40 -- File descriptor for current output
42 type FD_Array
is array (Nat
range 1 .. 3) of File_Descriptor
;
44 FD_Stack_Idx
: Nat
:= FD_Array
'First - 1;
45 -- Maintain a small stack for Push_Output and Pop_Output. We'd normally
46 -- use Table for this and allow an unlimited depth, but we're the target
47 -- of a pragma Elaborate_All in Table, so we can't use it here.
49 Special_Output_Proc
: Output_Proc
:= null;
50 -- Record argument to last call to Set_Special_Output. If this is
51 -- non-null, then we are in special output mode.
53 Indentation_Amount
: constant Positive := 3;
54 -- Number of spaces to output for each indentation level
56 Indentation_Limit
: constant Positive := 40;
57 -- Indentation beyond this number of spaces wraps around
59 pragma Assert
(Indentation_Limit
< Buffer_Max
/ 2);
60 -- Make sure this is substantially shorter than the line length
62 Cur_Indentation
: Natural := 0;
63 -- Number of spaces to indent each line
65 -----------------------
66 -- Local_Subprograms --
67 -----------------------
69 procedure Flush_Buffer
;
70 -- Flush buffer if non-empty and reset column counter
72 ---------------------------
73 -- Cancel_Special_Output --
74 ---------------------------
76 procedure Cancel_Special_Output
is
78 Special_Output_Proc
:= null;
79 end Cancel_Special_Output
;
85 function Column
return Pos
is
87 return Pos
(Next_Col
);
90 ----------------------
91 -- Delete_Last_Char --
92 ----------------------
94 procedure Delete_Last_Char
is
97 Next_Col
:= Next_Col
- 1;
105 procedure Flush_Buffer
is
106 Write_Error
: exception;
107 -- Raised if Write fails
113 procedure Write_Buffer
(Buf
: String);
114 -- Write out Buf, either using Special_Output_Proc, or the normal way
115 -- using Write. Raise Write_Error if Write fails (presumably due to disk
116 -- full). Write_Error is not used in the case of Special_Output_Proc.
118 procedure Write_Buffer
(Buf
: String) is
120 -- If Special_Output_Proc has been set, then use it
122 if Special_Output_Proc
/= null then
123 Special_Output_Proc
.all (Buf
);
125 -- If output is not set, then output to either standard output
126 -- or standard error.
128 elsif Write
(Current_FD
, Buf
'Address, Buf
'Length) /= Buf
'Length then
134 Len
: constant Natural := Next_Col
- 1;
136 -- Start of processing for Flush_Buffer
141 -- If there's no indentation, or if the line is too long with
142 -- indentation, or if it's a blank line, just write the buffer.
144 if Cur_Indentation
= 0
145 or else Cur_Indentation
+ Len
> Buffer_Max
146 or else Buffer
(1 .. Len
) = (1 => ASCII
.LF
)
148 Write_Buffer
(Buffer
(1 .. Len
));
150 -- Otherwise, construct a new buffer with preceding spaces, and
155 Indented_Buffer
: constant String :=
156 (1 .. Cur_Indentation
=> ' ') &
159 Write_Buffer
(Indented_Buffer
);
166 -- If there are errors with standard error just quit. Otherwise
167 -- set the output to standard error before reporting a failure
170 if Current_FD
/= Standerr
then
171 Current_FD
:= Standerr
;
173 Write_Line
("fatal error: disk full");
179 -- Buffer is now empty
189 procedure Ignore_Output
(S
: String) is
200 -- The "mod" in the following assignment is to cause a wrap around in
201 -- the case where there is too much indentation.
204 (Cur_Indentation
+ Indentation_Amount
) mod Indentation_Limit
;
211 function Last_Char
return Character is
213 if Next_Col
/= 1 then
214 return Buffer
(Next_Col
- 1);
226 -- The "mod" here undoes the wrap around from Indent above
229 (Cur_Indentation
- Indentation_Amount
) mod Indentation_Limit
;
236 procedure Pop_Output
is
239 pragma Assert
(FD_Stack_Idx
>= FD_Array
'First);
240 Current_FD
:= FD_Stack
(FD_Stack_Idx
);
241 FD_Stack_Idx
:= FD_Stack_Idx
- 1;
248 procedure Push_Output
is
250 pragma Assert
(FD_Stack_Idx
< FD_Array
'Last);
251 FD_Stack_Idx
:= FD_Stack_Idx
+ 1;
252 FD_Stack
(FD_Stack_Idx
) := Current_FD
;
255 ---------------------------
256 -- Restore_Output_Buffer --
257 ---------------------------
259 procedure Restore_Output_Buffer
(S
: Saved_Output_Buffer
) is
261 Next_Col
:= S
.Next_Col
;
262 Cur_Indentation
:= S
.Cur_Indentation
;
263 Buffer
(1 .. Next_Col
- 1) := S
.Buffer
(1 .. Next_Col
- 1);
264 end Restore_Output_Buffer
;
266 ------------------------
267 -- Save_Output_Buffer --
268 ------------------------
270 function Save_Output_Buffer
return Saved_Output_Buffer
is
271 S
: Saved_Output_Buffer
;
273 S
.Buffer
(1 .. Next_Col
- 1) := Buffer
(1 .. Next_Col
- 1);
274 S
.Next_Col
:= Next_Col
;
275 S
.Cur_Indentation
:= Cur_Indentation
;
277 Cur_Indentation
:= 0;
279 end Save_Output_Buffer
;
281 ------------------------
282 -- Set_Special_Output --
283 ------------------------
285 procedure Set_Special_Output
(P
: Output_Proc
) is
287 Special_Output_Proc
:= P
;
288 end Set_Special_Output
;
294 procedure Set_Output
(FD
: File_Descriptor
) is
300 ------------------------
301 -- Set_Standard_Error --
302 ------------------------
304 procedure Set_Standard_Error
is
306 Set_Output
(Standerr
);
307 end Set_Standard_Error
;
309 -------------------------
310 -- Set_Standard_Output --
311 -------------------------
313 procedure Set_Standard_Output
is
315 Set_Output
(Standout
);
316 end Set_Standard_Output
;
322 procedure w
(C
: Character) is
335 procedure w
(S
: String) is
346 procedure w
(V
: Int
) is
357 procedure w
(B
: Boolean) is
371 procedure w
(L
: String; C
: Character) is
383 procedure w
(L
: String; S
: String) is
395 procedure w
(L
: String; V
: Int
) is
407 procedure w
(L
: String; B
: Boolean) is
423 procedure Write_Char
(C
: Character) is
425 if Next_Col
> Buffer
'Length then
428 pragma Assert
(Next_Col
in Buffer
'Range);
433 Buffer
(Next_Col
) := C
;
434 Next_Col
:= Next_Col
+ 1;
442 procedure Write_Eol
is
444 -- Remove any trailing spaces
446 while Next_Col
> 1 and then Buffer
(Next_Col
- 1) = ' ' loop
447 Next_Col
:= Next_Col
- 1;
450 Buffer
(Next_Col
) := ASCII
.LF
;
451 Next_Col
:= Next_Col
+ 1;
455 ---------------------------
456 -- Write_Eol_Keep_Blanks --
457 ---------------------------
459 procedure Write_Eol_Keep_Blanks
is
461 Buffer
(Next_Col
) := ASCII
.LF
;
462 Next_Col
:= Next_Col
+ 1;
464 end Write_Eol_Keep_Blanks
;
466 ----------------------
467 -- Write_Erase_Char --
468 ----------------------
470 procedure Write_Erase_Char
(C
: Character) is
472 if Next_Col
/= 1 and then Buffer
(Next_Col
- 1) = C
then
473 Next_Col
:= Next_Col
- 1;
475 end Write_Erase_Char
;
481 procedure Write_Int
(Val
: Int
) is
482 -- Type Int has one extra negative number (i.e. two's complement), so we
483 -- work with negative numbers here. Otherwise, negating Int'First will
486 subtype Nonpositive
is Int
range Int
'First .. 0;
487 procedure Write_Abs
(Val
: Nonpositive
);
488 -- Write out the absolute value of Val
490 procedure Write_Abs
(Val
: Nonpositive
) is
493 Write_Abs
(Val
/ 10); -- Recursively write higher digits
496 Write_Char
(Character'Val (-(Val
rem 10) + Character'Pos ('0')));
512 procedure Write_Int_64
(Val
: Int_64
) is
513 subtype Nonpositive
is Int_64
range Int_64
'First .. 0;
514 procedure Write_Abs
(Val
: Nonpositive
);
516 procedure Write_Abs
(Val
: Nonpositive
) is
519 Write_Abs
(Val
/ 10);
522 Write_Char
(Character'Val (-(Val
rem 10) + Character'Pos ('0')));
538 procedure Write_Line
(S
: String) is
548 procedure Write_Spaces
(N
: Nat
) is
559 procedure Write_Str
(S
: String) is
561 for J
in S
'Range loop