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 pragma Warnings (Off);
33 with System.OS_Lib; use System.OS_Lib;
36 package body Output is
38 Current_FD : File_Descriptor := Standout;
39 -- File descriptor for current output
41 Special_Output_Proc : Output_Proc := null;
42 -- Record argument to last call to Set_Special_Output. If this is
43 -- non-null, then we are in special output mode.
45 Indentation_Amount : constant Positive := 3;
46 -- Number of spaces to output for each indentation level
48 Indentation_Limit : constant Positive := 40;
49 -- Indentation beyond this number of spaces wraps around
51 pragma Assert (Indentation_Limit < Buffer_Max / 2);
52 -- Make sure this is substantially shorter than the line length
54 Cur_Indentation : Natural := 0;
55 -- Number of spaces to indent each line
57 -----------------------
58 -- Local_Subprograms --
59 -----------------------
61 procedure Flush_Buffer;
62 -- Flush buffer if non-empty and reset column counter
64 ---------------------------
65 -- Cancel_Special_Output --
66 ---------------------------
68 procedure Cancel_Special_Output is
70 Special_Output_Proc := null;
71 end Cancel_Special_Output;
77 function Column return Pos is
79 return Pos (Next_Col);
86 procedure Flush_Buffer is
87 Write_Error : exception;
88 -- Raised if Write fails
94 procedure Write_Buffer (Buf : String);
95 -- Write out Buf, either using Special_Output_Proc, or the normal way
96 -- using Write. Raise Write_Error if Write fails (presumably due to disk
97 -- full). Write_Error is not used in the case of Special_Output_Proc.
99 procedure Write_Buffer (Buf : String) is
101 -- If Special_Output_Proc has been set, then use it
103 if Special_Output_Proc /= null then
104 Special_Output_Proc.all (Buf);
106 -- If output is not set, then output to either standard output
107 -- or standard error.
109 elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
115 Len : constant Natural := Next_Col - 1;
117 -- Start of processing for Flush_Buffer
122 -- If there's no indentation, or if the line is too long with
123 -- indentation, or if it's a blank line, just write the buffer.
125 if Cur_Indentation = 0
126 or else Cur_Indentation + Len > Buffer_Max
127 or else Buffer (1 .. Len) = (1 => ASCII.LF)
129 Write_Buffer (Buffer (1 .. Len));
131 -- Otherwise, construct a new buffer with preceding spaces, and
136 Indented_Buffer : constant String
137 := (1 .. Cur_Indentation => ' ') & Buffer (1 .. Len);
139 Write_Buffer (Indented_Buffer);
145 -- If there are errors with standard error, just quit.
146 -- Otherwise, set the output to standard error before reporting
147 -- a failure and quitting.
149 if Current_FD /= Standerr then
150 Current_FD := Standerr;
152 Write_Line ("fatal error: disk full");
158 -- Buffer is now empty
168 procedure Ignore_Output (S : String) is
179 -- The "mod" in the following assignment is to cause a wrap around in
180 -- the case where there is too much indentation.
183 (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
192 -- The "mod" here undoes the wrap around from Indent above
195 (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
198 ---------------------------
199 -- Restore_Output_Buffer --
200 ---------------------------
202 procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
204 Next_Col := S.Next_Col;
205 Cur_Indentation := S.Cur_Indentation;
206 Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
207 end Restore_Output_Buffer;
209 ------------------------
210 -- Save_Output_Buffer --
211 ------------------------
213 function Save_Output_Buffer return Saved_Output_Buffer is
214 S : Saved_Output_Buffer;
216 S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
217 S.Next_Col := Next_Col;
218 S.Cur_Indentation := Cur_Indentation;
220 Cur_Indentation := 0;
222 end Save_Output_Buffer;
224 ------------------------
225 -- Set_Special_Output --
226 ------------------------
228 procedure Set_Special_Output (P : Output_Proc) is
230 Special_Output_Proc := P;
231 end Set_Special_Output;
233 ------------------------
234 -- Set_Standard_Error --
235 ------------------------
237 procedure Set_Standard_Error is
239 if Special_Output_Proc = null then
243 Current_FD := Standerr;
244 end Set_Standard_Error;
246 -------------------------
247 -- Set_Standard_Output --
248 -------------------------
250 procedure Set_Standard_Output is
252 if Special_Output_Proc = null then
256 Current_FD := Standout;
257 end Set_Standard_Output;
263 procedure w (C : Character) is
271 procedure w (S : String) is
277 procedure w (V : Int) is
283 procedure w (B : Boolean) is
292 procedure w (L : String; C : Character) is
299 procedure w (L : String; S : String) is
306 procedure w (L : String; V : Int) is
313 procedure w (L : String; B : Boolean) is
324 procedure Write_Char (C : Character) is
326 if Next_Col = Buffer'Length then
333 Buffer (Next_Col) := C;
334 Next_Col := Next_Col + 1;
342 procedure Write_Eol is
344 -- Remove any trailing space
346 while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
347 Next_Col := Next_Col - 1;
350 Buffer (Next_Col) := ASCII.LF;
351 Next_Col := Next_Col + 1;
355 ---------------------------
356 -- Write_Eol_Keep_Blanks --
357 ---------------------------
359 procedure Write_Eol_Keep_Blanks is
361 Buffer (Next_Col) := ASCII.LF;
362 Next_Col := Next_Col + 1;
364 end Write_Eol_Keep_Blanks;
366 ----------------------
367 -- Write_Erase_Char --
368 ----------------------
370 procedure Write_Erase_Char (C : Character) is
372 if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
373 Next_Col := Next_Col - 1;
375 end Write_Erase_Char;
381 procedure Write_Int (Val : Int) is
389 Write_Int (Val / 10);
392 Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
400 procedure Write_Line (S : String) is
410 procedure Write_Spaces (N : Nat) is
421 procedure Write_Str (S : String) is
423 for J in S'Range loop