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