1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 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
66 Special_Output_Proc := null;
67 end Cancel_Special_Output;
73 function Column return Pos is
75 return Pos (Next_Col);
82 procedure Flush_Buffer is
83 Write_Error : exception;
84 -- Raised if Write fails
90 procedure Write_Buffer (Buf : String);
91 -- Write out Buf, either using Special_Output_Proc, or the normal way
92 -- using Write. Raise Write_Error if Write fails (presumably due to disk
93 -- full). Write_Error is not used in the case of Special_Output_Proc.
95 procedure Write_Buffer (Buf : String) is
97 -- If Special_Output_Proc has been set, then use it
99 if Special_Output_Proc /= null then
100 Special_Output_Proc.all (Buf);
102 -- If output is not set, then output to either standard output
103 -- or standard error.
105 elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
111 Len : constant Natural := Next_Col - 1;
113 -- Start of processing for Flush_Buffer
118 -- If there's no indentation, or if the line is too long with
119 -- indentation, or if it's a blank line, just write the buffer.
121 if Cur_Indentation = 0
122 or else Cur_Indentation + Len > Buffer_Max
123 or else Buffer (1 .. Len) = (1 => ASCII.LF)
125 Write_Buffer (Buffer (1 .. Len));
127 -- Otherwise, construct a new buffer with preceding spaces, and
132 Indented_Buffer : constant String :=
133 (1 .. Cur_Indentation => ' ') &
136 Write_Buffer (Indented_Buffer);
143 -- If there are errors with standard error just quit. Otherwise
144 -- set the output to standard error before reporting a failure
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;
235 procedure Set_Output (FD : File_Descriptor) is
237 if Special_Output_Proc = null then
244 ------------------------
245 -- Set_Standard_Error --
246 ------------------------
248 procedure Set_Standard_Error is
250 Set_Output (Standerr);
251 end Set_Standard_Error;
253 -------------------------
254 -- Set_Standard_Output --
255 -------------------------
257 procedure Set_Standard_Output is
259 Set_Output (Standout);
260 end Set_Standard_Output;
266 procedure w (C : Character) is
274 procedure w (S : String) is
280 procedure w (V : Int) is
286 procedure w (B : Boolean) is
295 procedure w (L : String; C : Character) is
302 procedure w (L : String; S : String) is
309 procedure w (L : String; V : Int) is
316 procedure w (L : String; B : Boolean) is
327 procedure Write_Char (C : Character) is
329 if Next_Col = Buffer'Length then
336 Buffer (Next_Col) := C;
337 Next_Col := Next_Col + 1;
345 procedure Write_Eol is
347 -- Remove any trailing space
349 while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
350 Next_Col := Next_Col - 1;
353 Buffer (Next_Col) := ASCII.LF;
354 Next_Col := Next_Col + 1;
358 ---------------------------
359 -- Write_Eol_Keep_Blanks --
360 ---------------------------
362 procedure Write_Eol_Keep_Blanks is
364 Buffer (Next_Col) := ASCII.LF;
365 Next_Col := Next_Col + 1;
367 end Write_Eol_Keep_Blanks;
369 ----------------------
370 -- Write_Erase_Char --
371 ----------------------
373 procedure Write_Erase_Char (C : Character) is
375 if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
376 Next_Col := Next_Col - 1;
378 end Write_Erase_Char;
384 procedure Write_Int (Val : Int) is
392 Write_Int (Val / 10);
395 Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
403 procedure Write_Line (S : String) is
413 procedure Write_Spaces (N : Nat) is
424 procedure Write_Str (S : String) is
426 for J in S'Range loop