-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- --
------------------------------------------------------------------------------
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with System.OS_Lib; use System.OS_Lib;
package body Output is
-- Record argument to last call to Set_Special_Output. If this is
-- non-null, then we are in special output mode.
- -------------------------
- -- Line Buffer Control --
- -------------------------
-
- -- Note: the following buffer and column position are maintained by
- -- the subprograms defined in this package, and are not normally
- -- directly modified or accessed by a client. However, a client is
- -- permitted to modify these values, using the knowledge that only
- -- Write_Eol actually generates any output.
-
- Buffer_Max : constant := 8192;
- Buffer : String (1 .. Buffer_Max + 1);
- -- Buffer used to build output line. We do line buffering because it
- -- is needed for the support of the debug-generated-code option (-gnatD).
- -- Historically it was first added because on VMS, line buffering is
- -- needed with certain file formats. So in any case line buffering must
- -- be retained for this purpose, even if other reasons disappear. Note
- -- any attempt to write more output to a line than can fit in the buffer
- -- will be silently ignored.
-
- Next_Column : Pos range 1 .. Buffer'Length + 1 := 1;
- -- Column about to be written.
-
-----------------------
-- Local_Subprograms --
-----------------------
Special_Output_Proc := null;
end Cancel_Special_Output;
+ ------------
+ -- Column --
+ ------------
+
+ function Column return Pos is
+ begin
+ return Pos (Next_Col);
+ end Column;
+
------------------
-- Flush_Buffer --
------------------
procedure Flush_Buffer is
- Len : constant Natural := Natural (Next_Column - 1);
+ Len : constant Natural := Next_Col - 1;
begin
if Len /= 0 then
else
Current_FD := Standerr;
- Next_Column := 1;
+ Next_Col := 1;
Write_Line ("fatal error: disk full");
OS_Exit (2);
end if;
-- Buffer is now empty
- Next_Column := 1;
+ Next_Col := 1;
end if;
end Flush_Buffer;
- ------------
- -- Column --
- ------------
+ ---------------------------
+ -- Restore_Output_Buffer --
+ ---------------------------
- function Column return Nat is
+ procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
begin
- return Next_Column;
- end Column;
+ Next_Col := S.Next_Col;
+ Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
+ end Restore_Output_Buffer;
+
+ ------------------------
+ -- Save_Output_Buffer --
+ ------------------------
+
+ function Save_Output_Buffer return Saved_Output_Buffer is
+ S : Saved_Output_Buffer;
+ begin
+ S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
+ S.Next_Col := Next_Col;
+ Next_Col := 1;
+ return S;
+ end Save_Output_Buffer;
------------------------
-- Set_Special_Output --
begin
if Special_Output_Proc = null then
Flush_Buffer;
- Next_Column := 1;
+ Next_Col := 1;
end if;
Current_FD := Standerr;
begin
if Special_Output_Proc = null then
Flush_Buffer;
- Next_Column := 1;
+ Next_Col := 1;
end if;
Current_FD := Standout;
procedure Write_Char (C : Character) is
begin
- if Next_Column = Buffer'Length then
+ if Next_Col = Buffer'Length then
Write_Eol;
end if;
- Buffer (Natural (Next_Column)) := C;
- Next_Column := Next_Column + 1;
+ if C = ASCII.LF then
+ Write_Eol;
+ else
+ Buffer (Next_Col) := C;
+ Next_Col := Next_Col + 1;
+ end if;
end Write_Char;
---------------
procedure Write_Eol is
begin
- Buffer (Natural (Next_Column)) := ASCII.LF;
- Next_Column := Next_Column + 1;
+ -- Remove any trailing space
+
+ while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
+ Next_Col := Next_Col - 1;
+ end loop;
+
+ Buffer (Next_Col) := ASCII.LF;
+ Next_Col := Next_Col + 1;
Flush_Buffer;
end Write_Eol;
+ ---------------------------
+ -- Write_Eol_Keep_Blanks --
+ ---------------------------
+
+ procedure Write_Eol_Keep_Blanks is
+ begin
+ Buffer (Next_Col) := ASCII.LF;
+ Next_Col := Next_Col + 1;
+ Flush_Buffer;
+ end Write_Eol_Keep_Blanks;
+
+ ----------------------
+ -- Write_Erase_Char --
+ ----------------------
+
+ procedure Write_Erase_Char (C : Character) is
+ begin
+ if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
+ Next_Col := Next_Col - 1;
+ end if;
+ end Write_Erase_Char;
+
---------------
-- Write_Int --
---------------
Write_Eol;
end Write_Line;
+ ------------------
+ -- Write_Spaces --
+ ------------------
+
+ procedure Write_Spaces (N : Nat) is
+ begin
+ for J in 1 .. N loop
+ Write_Char (' ');
+ end loop;
+ end Write_Spaces;
+
---------------
-- Write_Str --
---------------
OSDN Git Service
