gcc/ada/output.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               O U T P U T                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.43 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with GNAT.OS_Lib; use GNAT.OS_Lib;
  37
  38 package body Output is
  39
  40    Current_FD : File_Descriptor := Standout;
  41    --  File descriptor for current output
  42
  43    -----------------------
  44    -- Local_Subprograms --
  45    -----------------------
  46
  47    procedure Flush_Buffer;
  48    --  Flush buffer if non-empty and reset column counter
  49
  50    ------------------
  51    -- Flush_Buffer --
  52    ------------------
  53
  54    procedure Flush_Buffer is
  55       Len : constant Natural := Natural (Column - 1);
  56
  57    begin
  58       if Len /= 0 then
  59          if Len /= Write (Current_FD, Buffer'Address, Len) then
  60             Set_Standard_Error;
  61             Write_Line ("fatal error: disk full");
  62             OS_Exit (2);
  63          end if;
  64
  65          Column := 1;
  66       end if;
  67    end Flush_Buffer;
  68
  69    ------------------------
  70    -- Set_Standard_Error --
  71    ------------------------
  72
  73    procedure Set_Standard_Error is
  74    begin
  75       Flush_Buffer;
  76       Current_FD := Standerr;
  77       Column := 1;
  78    end Set_Standard_Error;
  79
  80    -------------------------
  81    -- Set_Standard_Output --
  82    -------------------------
  83
  84    procedure Set_Standard_Output is
  85    begin
  86       Flush_Buffer;
  87       Current_FD := Standout;
  88       Column := 1;
  89    end Set_Standard_Output;
  90
  91    -------
  92    -- w --
  93    -------
  94
  95    procedure w (C : Character) is
  96    begin
  97       Write_Char (''');
  98       Write_Char (C);
  99       Write_Char (''');
 100       Write_Eol;
 101    end w;
 102
 103    procedure w (S : String) is
 104    begin
 105       Write_Str (S);
 106       Write_Eol;
 107    end w;
 108
 109    procedure w (V : Int) is
 110    begin
 111       Write_Int (V);
 112       Write_Eol;
 113    end w;
 114
 115    procedure w (B : Boolean) is
 116    begin
 117       if B then
 118          w ("True");
 119       else
 120          w ("False");
 121       end if;
 122    end w;
 123
 124    procedure w (L : String; C : Character) is
 125    begin
 126       Write_Str (L);
 127       Write_Char (' ');
 128       w (C);
 129    end w;
 130
 131    procedure w (L : String; S : String) is
 132    begin
 133       Write_Str (L);
 134       Write_Char (' ');
 135       w (S);
 136    end w;
 137
 138    procedure w (L : String; V : Int) is
 139    begin
 140       Write_Str (L);
 141       Write_Char (' ');
 142       w (V);
 143    end w;
 144
 145    procedure w (L : String; B : Boolean) is
 146    begin
 147       Write_Str (L);
 148       Write_Char (' ');
 149       w (B);
 150    end w;
 151
 152    ----------------
 153    -- Write_Char --
 154    ----------------
 155
 156    procedure Write_Char (C : Character) is
 157    begin
 158       if Column < Buffer'Length then
 159          Buffer (Natural (Column)) := C;
 160          Column := Column + 1;
 161       end if;
 162    end Write_Char;
 163
 164    ---------------
 165    -- Write_Eol --
 166    ---------------
 167
 168    procedure Write_Eol is
 169    begin
 170       Buffer (Natural (Column)) := ASCII.LF;
 171       Column := Column + 1;
 172       Flush_Buffer;
 173    end Write_Eol;
 174
 175    ---------------
 176    -- Write_Int --
 177    ---------------
 178
 179    procedure Write_Int (Val : Int) is
 180    begin
 181       if Val < 0 then
 182          Write_Char ('-');
 183          Write_Int (-Val);
 184
 185       else
 186          if Val > 9 then
 187             Write_Int (Val / 10);
 188          end if;
 189
 190          Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
 191       end if;
 192    end Write_Int;
 193
 194    ----------------
 195    -- Write_Line --
 196    ----------------
 197
 198    procedure Write_Line (S : String) is
 199    begin
 200       Write_Str (S);
 201       Write_Eol;
 202    end Write_Line;
 203
 204    ---------------
 205    -- Write_Str --
 206    ---------------
 207
 208    procedure Write_Str (S : String) is
 209    begin
 210       for J in S'Range loop
 211          Write_Char (S (J));
 212       end loop;
 213    end Write_Str;
 214
 215 end Output;