1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 with System
.OS_Lib
; use System
.OS_Lib
;
34 package body Output
is
36 Current_FD
: File_Descriptor
:= Standout
;
37 -- File descriptor for current output
39 Special_Output_Proc
: Output_Proc
:= null;
40 -- Record argument to last call to Set_Special_Output. If this is
41 -- non-null, then we are in special output mode.
43 Indentation_Amount
: constant Positive := 3;
44 -- Number of spaces to output for each indentation level
46 Indentation_Limit
: constant Positive := 40;
47 -- Indentation beyond this number of spaces wraps around
49 pragma Assert
(Indentation_Limit
< Buffer_Max
/ 2);
50 -- Make sure this is substantially shorter than the line length
52 Cur_Indentation
: Natural := 0;
53 -- Number of spaces to indent each line
55 -----------------------
56 -- Local_Subprograms --
57 -----------------------
59 procedure Flush_Buffer
;
60 -- Flush buffer if non-empty and reset column counter
62 ---------------------------
63 -- Cancel_Special_Output --
64 ---------------------------
66 procedure Cancel_Special_Output
is
68 Special_Output_Proc
:= null;
69 end Cancel_Special_Output
;
75 function Column
return Pos
is
77 return Pos
(Next_Col
);
84 procedure Flush_Buffer
is
85 Write_Error
: exception;
86 -- Raised if Write fails
92 procedure Write_Buffer
(Buf
: String);
93 -- Write out Buf, either using Special_Output_Proc, or the normal way
94 -- using Write. Raise Write_Error if Write fails (presumably due to disk
95 -- full). Write_Error is not used in the case of Special_Output_Proc.
97 procedure Write_Buffer
(Buf
: String) is
99 -- If Special_Output_Proc has been set, then use it
101 if Special_Output_Proc
/= null then
102 Special_Output_Proc
.all (Buf
);
104 -- If output is not set, then output to either standard output
105 -- or standard error.
107 elsif Write
(Current_FD
, Buf
'Address, Buf
'Length) /= Buf
'Length then
113 Len
: constant Natural := Next_Col
- 1;
115 -- Start of processing for Flush_Buffer
120 -- If there's no indentation, or if the line is too long with
121 -- indentation, or if it's a blank line, just write the buffer.
123 if Cur_Indentation
= 0
124 or else Cur_Indentation
+ Len
> Buffer_Max
125 or else Buffer
(1 .. Len
) = (1 => ASCII
.LF
)
127 Write_Buffer
(Buffer
(1 .. Len
));
129 -- Otherwise, construct a new buffer with preceding spaces, and
134 Indented_Buffer
: constant String
135 := (1 .. Cur_Indentation
=> ' ') & Buffer
(1 .. Len
);
137 Write_Buffer
(Indented_Buffer
);
143 -- If there are errors with standard error, just quit.
144 -- Otherwise, set the output to standard error before reporting
145 -- a failure and quitting.
147 if Current_FD
/= Standerr
then
148 Current_FD
:= Standerr
;
150 Write_Line
("fatal error: disk full");
156 -- Buffer is now empty
166 procedure Ignore_Output
(S
: String) is
177 -- The "mod" in the following assignment is to cause a wrap around in
178 -- the case where there is too much indentation.
181 (Cur_Indentation
+ Indentation_Amount
) mod Indentation_Limit
;
190 -- The "mod" here undoes the wrap around from Indent above
193 (Cur_Indentation
- Indentation_Amount
) mod Indentation_Limit
;
196 ---------------------------
197 -- Restore_Output_Buffer --
198 ---------------------------
200 procedure Restore_Output_Buffer
(S
: Saved_Output_Buffer
) is
202 Next_Col
:= S
.Next_Col
;
203 Cur_Indentation
:= S
.Cur_Indentation
;
204 Buffer
(1 .. Next_Col
- 1) := S
.Buffer
(1 .. Next_Col
- 1);
205 end Restore_Output_Buffer
;
207 ------------------------
208 -- Save_Output_Buffer --
209 ------------------------
211 function Save_Output_Buffer
return Saved_Output_Buffer
is
212 S
: Saved_Output_Buffer
;
214 S
.Buffer
(1 .. Next_Col
- 1) := Buffer
(1 .. Next_Col
- 1);
215 S
.Next_Col
:= Next_Col
;
216 S
.Cur_Indentation
:= Cur_Indentation
;
218 Cur_Indentation
:= 0;
220 end Save_Output_Buffer
;
222 ------------------------
223 -- Set_Special_Output --
224 ------------------------
226 procedure Set_Special_Output
(P
: Output_Proc
) is
228 Special_Output_Proc
:= P
;
229 end Set_Special_Output
;
231 ------------------------
232 -- Set_Standard_Error --
233 ------------------------
235 procedure Set_Standard_Error
is
237 if Special_Output_Proc
= null then
241 Current_FD
:= Standerr
;
242 end Set_Standard_Error
;
244 -------------------------
245 -- Set_Standard_Output --
246 -------------------------
248 procedure Set_Standard_Output
is
250 if Special_Output_Proc
= null then
254 Current_FD
:= Standout
;
255 end Set_Standard_Output
;
261 procedure w
(C
: Character) is
269 procedure w
(S
: String) is
275 procedure w
(V
: Int
) is
281 procedure w
(B
: Boolean) is
290 procedure w
(L
: String; C
: Character) is
297 procedure w
(L
: String; S
: String) is
304 procedure w
(L
: String; V
: Int
) is
311 procedure w
(L
: String; B
: Boolean) is
322 procedure Write_Char
(C
: Character) is
324 if Next_Col
= Buffer
'Length then
331 Buffer
(Next_Col
) := C
;
332 Next_Col
:= Next_Col
+ 1;
340 procedure Write_Eol
is
342 -- Remove any trailing space
344 while Next_Col
> 1 and then Buffer
(Next_Col
- 1) = ' ' loop
345 Next_Col
:= Next_Col
- 1;
348 Buffer
(Next_Col
) := ASCII
.LF
;
349 Next_Col
:= Next_Col
+ 1;
353 ---------------------------
354 -- Write_Eol_Keep_Blanks --
355 ---------------------------
357 procedure Write_Eol_Keep_Blanks
is
359 Buffer
(Next_Col
) := ASCII
.LF
;
360 Next_Col
:= Next_Col
+ 1;
362 end Write_Eol_Keep_Blanks
;
364 ----------------------
365 -- Write_Erase_Char --
366 ----------------------
368 procedure Write_Erase_Char
(C
: Character) is
370 if Next_Col
/= 1 and then Buffer
(Next_Col
- 1) = C
then
371 Next_Col
:= Next_Col
- 1;
373 end Write_Erase_Char
;
379 procedure Write_Int
(Val
: Int
) is
387 Write_Int
(Val
/ 10);
390 Write_Char
(Character'Val ((Val
mod 10) + Character'Pos ('0')));
398 procedure Write_Line
(S
: String) is
408 procedure Write_Spaces
(N
: Nat
) is
419 procedure Write_Str
(S
: String) is
421 for J
in S
'Range loop