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 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  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.                                     --
  17 --                                                                          --
  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.               --
  21 --                                                                          --
  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/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.OS_Lib; use System.OS_Lib;
  33
  34 package body Output is
  35
  36    Current_FD : File_Descriptor := Standout;
  37    --  File descriptor for current output
  38
  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.
  42
  43    Indentation_Amount : constant Positive := 3;
  44    --  Number of spaces to output for each indentation level
  45
  46    Indentation_Limit : constant Positive := 40;
  47    --  Indentation beyond this number of spaces wraps around
  48
  49    pragma Assert (Indentation_Limit < Buffer_Max / 2);
  50    --  Make sure this is substantially shorter than the line length
  51
  52    Cur_Indentation : Natural := 0;
  53    --  Number of spaces to indent each line
  54
  55    -----------------------
  56    -- Local_Subprograms --
  57    -----------------------
  58
  59    procedure Flush_Buffer;
  60    --  Flush buffer if non-empty and reset column counter
  61
  62    ---------------------------
  63    -- Cancel_Special_Output --
  64    ---------------------------
  65
  66    procedure Cancel_Special_Output is
  67    begin
  68       Special_Output_Proc := null;
  69    end Cancel_Special_Output;
  70
  71    ------------
  72    -- Column --
  73    ------------
  74
  75    function Column return Pos is
  76    begin
  77       return Pos (Next_Col);
  78    end Column;
  79
  80    ------------------
  81    -- Flush_Buffer --
  82    ------------------
  83
  84    procedure Flush_Buffer is
  85       Write_Error : exception;
  86       --  Raised if Write fails
  87
  88       ------------------
  89       -- Write_Buffer --
  90       ------------------
  91
  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.
  96
  97       procedure Write_Buffer (Buf : String) is
  98       begin
  99          --  If Special_Output_Proc has been set, then use it
 100
 101          if Special_Output_Proc /= null then
 102             Special_Output_Proc.all (Buf);
 103
 104          --  If output is not set, then output to either standard output
 105          --  or standard error.
 106
 107          elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
 108             raise Write_Error;
 109
 110          end if;
 111       end Write_Buffer;
 112
 113       Len : constant Natural := Next_Col - 1;
 114
 115    --  Start of processing for Flush_Buffer
 116
 117    begin
 118       if Len /= 0 then
 119          begin
 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.
 122
 123             if Cur_Indentation = 0
 124               or else Cur_Indentation + Len > Buffer_Max
 125               or else Buffer (1 .. Len) = (1 => ASCII.LF)
 126             then
 127                Write_Buffer (Buffer (1 .. Len));
 128
 129             --  Otherwise, construct a new buffer with preceding spaces, and
 130             --  write that.
 131
 132             else
 133                declare
 134                   Indented_Buffer : constant String
 135                     := (1 .. Cur_Indentation => ' ') & Buffer (1 .. Len);
 136                begin
 137                   Write_Buffer (Indented_Buffer);
 138                end;
 139             end if;
 140
 141          exception
 142             when Write_Error =>
 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.
 146
 147                if Current_FD /= Standerr then
 148                   Current_FD := Standerr;
 149                   Next_Col := 1;
 150                   Write_Line ("fatal error: disk full");
 151                end if;
 152
 153                OS_Exit (2);
 154          end;
 155
 156          --  Buffer is now empty
 157
 158          Next_Col := 1;
 159       end if;
 160    end Flush_Buffer;
 161
 162    -------------------
 163    -- Ignore_Output --
 164    -------------------
 165
 166    procedure Ignore_Output (S : String) is
 167    begin
 168       null;
 169    end Ignore_Output;
 170
 171    ------------
 172    -- Indent --
 173    ------------
 174
 175    procedure Indent is
 176    begin
 177       --  The "mod" in the following assignment is to cause a wrap around in
 178       --  the case where there is too much indentation.
 179
 180       Cur_Indentation :=
 181         (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
 182    end Indent;
 183
 184    -------------
 185    -- Outdent --
 186    -------------
 187
 188    procedure Outdent is
 189    begin
 190       --  The "mod" here undoes the wrap around from Indent above
 191
 192       Cur_Indentation :=
 193         (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
 194    end Outdent;
 195
 196    ---------------------------
 197    -- Restore_Output_Buffer --
 198    ---------------------------
 199
 200    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
 201    begin
 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;
 206
 207    ------------------------
 208    -- Save_Output_Buffer --
 209    ------------------------
 210
 211    function Save_Output_Buffer return Saved_Output_Buffer is
 212       S : Saved_Output_Buffer;
 213    begin
 214       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
 215       S.Next_Col := Next_Col;
 216       S.Cur_Indentation := Cur_Indentation;
 217       Next_Col := 1;
 218       Cur_Indentation := 0;
 219       return S;
 220    end Save_Output_Buffer;
 221
 222    ------------------------
 223    -- Set_Special_Output --
 224    ------------------------
 225
 226    procedure Set_Special_Output (P : Output_Proc) is
 227    begin
 228       Special_Output_Proc := P;
 229    end Set_Special_Output;
 230
 231    ------------------------
 232    -- Set_Standard_Error --
 233    ------------------------
 234
 235    procedure Set_Standard_Error is
 236    begin
 237       if Special_Output_Proc = null then
 238          Flush_Buffer;
 239       end if;
 240
 241       Current_FD := Standerr;
 242    end Set_Standard_Error;
 243
 244    -------------------------
 245    -- Set_Standard_Output --
 246    -------------------------
 247
 248    procedure Set_Standard_Output is
 249    begin
 250       if Special_Output_Proc = null then
 251          Flush_Buffer;
 252       end if;
 253
 254       Current_FD := Standout;
 255    end Set_Standard_Output;
 256
 257    -------
 258    -- w --
 259    -------
 260
 261    procedure w (C : Character) is
 262    begin
 263       Write_Char (''');
 264       Write_Char (C);
 265       Write_Char (''');
 266       Write_Eol;
 267    end w;
 268
 269    procedure w (S : String) is
 270    begin
 271       Write_Str (S);
 272       Write_Eol;
 273    end w;
 274
 275    procedure w (V : Int) is
 276    begin
 277       Write_Int (V);
 278       Write_Eol;
 279    end w;
 280
 281    procedure w (B : Boolean) is
 282    begin
 283       if B then
 284          w ("True");
 285       else
 286          w ("False");
 287       end if;
 288    end w;
 289
 290    procedure w (L : String; C : Character) is
 291    begin
 292       Write_Str (L);
 293       Write_Char (' ');
 294       w (C);
 295    end w;
 296
 297    procedure w (L : String; S : String) is
 298    begin
 299       Write_Str (L);
 300       Write_Char (' ');
 301       w (S);
 302    end w;
 303
 304    procedure w (L : String; V : Int) is
 305    begin
 306       Write_Str (L);
 307       Write_Char (' ');
 308       w (V);
 309    end w;
 310
 311    procedure w (L : String; B : Boolean) is
 312    begin
 313       Write_Str (L);
 314       Write_Char (' ');
 315       w (B);
 316    end w;
 317
 318    ----------------
 319    -- Write_Char --
 320    ----------------
 321
 322    procedure Write_Char (C : Character) is
 323    begin
 324       if Next_Col = Buffer'Length then
 325          Write_Eol;
 326       end if;
 327
 328       if C = ASCII.LF then
 329          Write_Eol;
 330       else
 331          Buffer (Next_Col) := C;
 332          Next_Col := Next_Col + 1;
 333       end if;
 334    end Write_Char;
 335
 336    ---------------
 337    -- Write_Eol --
 338    ---------------
 339
 340    procedure Write_Eol is
 341    begin
 342       --  Remove any trailing space
 343
 344       while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
 345          Next_Col := Next_Col - 1;
 346       end loop;
 347
 348       Buffer (Next_Col) := ASCII.LF;
 349       Next_Col := Next_Col + 1;
 350       Flush_Buffer;
 351    end Write_Eol;
 352
 353    ---------------------------
 354    -- Write_Eol_Keep_Blanks --
 355    ---------------------------
 356
 357    procedure Write_Eol_Keep_Blanks is
 358    begin
 359       Buffer (Next_Col) := ASCII.LF;
 360       Next_Col := Next_Col + 1;
 361       Flush_Buffer;
 362    end Write_Eol_Keep_Blanks;
 363
 364    ----------------------
 365    -- Write_Erase_Char --
 366    ----------------------
 367
 368    procedure Write_Erase_Char (C : Character) is
 369    begin
 370       if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
 371          Next_Col := Next_Col - 1;
 372       end if;
 373    end Write_Erase_Char;
 374
 375    ---------------
 376    -- Write_Int --
 377    ---------------
 378
 379    procedure Write_Int (Val : Int) is
 380    begin
 381       if Val < 0 then
 382          Write_Char ('-');
 383          Write_Int (-Val);
 384
 385       else
 386          if Val > 9 then
 387             Write_Int (Val / 10);
 388          end if;
 389
 390          Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
 391       end if;
 392    end Write_Int;
 393
 394    ----------------
 395    -- Write_Line --
 396    ----------------
 397
 398    procedure Write_Line (S : String) is
 399    begin
 400       Write_Str (S);
 401       Write_Eol;
 402    end Write_Line;
 403
 404    ------------------
 405    -- Write_Spaces --
 406    ------------------
 407
 408    procedure Write_Spaces (N : Nat) is
 409    begin
 410       for J in 1 .. N loop
 411          Write_Char (' ');
 412       end loop;
 413    end Write_Spaces;
 414
 415    ---------------
 416    -- Write_Str --
 417    ---------------
 418
 419    procedure Write_Str (S : String) is
 420    begin
 421       for J in S'Range loop
 422          Write_Char (S (J));
 423       end loop;
 424    end Write_Str;
 425
 426 end Output;