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    begin
 116       if Len /= 0 then
 117          begin
 118             --  If there's no indentation, or if the line is too long with
 119             --  indentation, just write the buffer.
 120
 121             if Cur_Indentation = 0
 122               or else Cur_Indentation + Len > Buffer_Max
 123             then
 124                Write_Buffer (Buffer (1 .. Len));
 125
 126             --  Otherwise, construct a new buffer with preceding spaces, and
 127             --  write that.
 128
 129             else
 130                declare
 131                   Indented_Buffer : constant String
 132                     := (1 .. Cur_Indentation => ' ') & Buffer (1 .. Len);
 133                begin
 134                   Write_Buffer (Indented_Buffer);
 135                end;
 136             end if;
 137
 138          exception
 139             when Write_Error =>
 140                --  If there are errors with standard error, just quit.
 141                --  Otherwise, set the output to standard error before reporting
 142                --  a failure and quitting.
 143
 144                if Current_FD /= Standerr then
 145                   Current_FD := Standerr;
 146                   Next_Col := 1;
 147                   Write_Line ("fatal error: disk full");
 148                end if;
 149
 150                OS_Exit (2);
 151          end;
 152
 153          --  Buffer is now empty
 154
 155          Next_Col := 1;
 156       end if;
 157    end Flush_Buffer;
 158
 159    ------------
 160    -- Indent --
 161    ------------
 162
 163    procedure Indent is
 164    begin
 165       Cur_Indentation :=
 166         (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
 167       --  The "mod" is to wrap around in case there's too much indentation
 168    end Indent;
 169
 170    -------------
 171    -- Outdent --
 172    -------------
 173
 174    procedure Outdent is
 175    begin
 176       Cur_Indentation :=
 177         (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
 178    end Outdent;
 179
 180    ---------------------------
 181    -- Restore_Output_Buffer --
 182    ---------------------------
 183
 184    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
 185    begin
 186       Next_Col := S.Next_Col;
 187       Cur_Indentation := S.Cur_Indentation;
 188       Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
 189    end Restore_Output_Buffer;
 190
 191    ------------------------
 192    -- Save_Output_Buffer --
 193    ------------------------
 194
 195    function Save_Output_Buffer return Saved_Output_Buffer is
 196       S : Saved_Output_Buffer;
 197    begin
 198       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
 199       S.Next_Col := Next_Col;
 200       S.Cur_Indentation := Cur_Indentation;
 201       Next_Col := 1;
 202       Cur_Indentation := 0;
 203       return S;
 204    end Save_Output_Buffer;
 205
 206    ------------------------
 207    -- Set_Special_Output --
 208    ------------------------
 209
 210    procedure Set_Special_Output (P : Output_Proc) is
 211    begin
 212       Special_Output_Proc := P;
 213    end Set_Special_Output;
 214
 215    ------------------------
 216    -- Set_Standard_Error --
 217    ------------------------
 218
 219    procedure Set_Standard_Error is
 220    begin
 221       if Special_Output_Proc = null then
 222          Flush_Buffer;
 223       end if;
 224
 225       Current_FD := Standerr;
 226    end Set_Standard_Error;
 227
 228    -------------------------
 229    -- Set_Standard_Output --
 230    -------------------------
 231
 232    procedure Set_Standard_Output is
 233    begin
 234       if Special_Output_Proc = null then
 235          Flush_Buffer;
 236       end if;
 237
 238       Current_FD := Standout;
 239    end Set_Standard_Output;
 240
 241    -------
 242    -- w --
 243    -------
 244
 245    procedure w (C : Character) is
 246    begin
 247       Write_Char (''');
 248       Write_Char (C);
 249       Write_Char (''');
 250       Write_Eol;
 251    end w;
 252
 253    procedure w (S : String) is
 254    begin
 255       Write_Str (S);
 256       Write_Eol;
 257    end w;
 258
 259    procedure w (V : Int) is
 260    begin
 261       Write_Int (V);
 262       Write_Eol;
 263    end w;
 264
 265    procedure w (B : Boolean) is
 266    begin
 267       if B then
 268          w ("True");
 269       else
 270          w ("False");
 271       end if;
 272    end w;
 273
 274    procedure w (L : String; C : Character) is
 275    begin
 276       Write_Str (L);
 277       Write_Char (' ');
 278       w (C);
 279    end w;
 280
 281    procedure w (L : String; S : String) is
 282    begin
 283       Write_Str (L);
 284       Write_Char (' ');
 285       w (S);
 286    end w;
 287
 288    procedure w (L : String; V : Int) is
 289    begin
 290       Write_Str (L);
 291       Write_Char (' ');
 292       w (V);
 293    end w;
 294
 295    procedure w (L : String; B : Boolean) is
 296    begin
 297       Write_Str (L);
 298       Write_Char (' ');
 299       w (B);
 300    end w;
 301
 302    ----------------
 303    -- Write_Char --
 304    ----------------
 305
 306    procedure Write_Char (C : Character) is
 307    begin
 308       if Next_Col = Buffer'Length then
 309          Write_Eol;
 310       end if;
 311
 312       if C = ASCII.LF then
 313          Write_Eol;
 314       else
 315          Buffer (Next_Col) := C;
 316          Next_Col := Next_Col + 1;
 317       end if;
 318    end Write_Char;
 319
 320    ---------------
 321    -- Write_Eol --
 322    ---------------
 323
 324    procedure Write_Eol is
 325    begin
 326       --  Remove any trailing space
 327
 328       while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
 329          Next_Col := Next_Col - 1;
 330       end loop;
 331
 332       Buffer (Next_Col) := ASCII.LF;
 333       Next_Col := Next_Col + 1;
 334       Flush_Buffer;
 335    end Write_Eol;
 336
 337    ---------------------------
 338    -- Write_Eol_Keep_Blanks --
 339    ---------------------------
 340
 341    procedure Write_Eol_Keep_Blanks is
 342    begin
 343       Buffer (Next_Col) := ASCII.LF;
 344       Next_Col := Next_Col + 1;
 345       Flush_Buffer;
 346    end Write_Eol_Keep_Blanks;
 347
 348    ----------------------
 349    -- Write_Erase_Char --
 350    ----------------------
 351
 352    procedure Write_Erase_Char (C : Character) is
 353    begin
 354       if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
 355          Next_Col := Next_Col - 1;
 356       end if;
 357    end Write_Erase_Char;
 358
 359    ---------------
 360    -- Write_Int --
 361    ---------------
 362
 363    procedure Write_Int (Val : Int) is
 364    begin
 365       if Val < 0 then
 366          Write_Char ('-');
 367          Write_Int (-Val);
 368
 369       else
 370          if Val > 9 then
 371             Write_Int (Val / 10);
 372          end if;
 373
 374          Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
 375       end if;
 376    end Write_Int;
 377
 378    ----------------
 379    -- Write_Line --
 380    ----------------
 381
 382    procedure Write_Line (S : String) is
 383    begin
 384       Write_Str (S);
 385       Write_Eol;
 386    end Write_Line;
 387
 388    ------------------
 389    -- Write_Spaces --
 390    ------------------
 391
 392    procedure Write_Spaces (N : Nat) is
 393    begin
 394       for J in 1 .. N loop
 395          Write_Char (' ');
 396       end loop;
 397    end Write_Spaces;
 398
 399    ---------------
 400    -- Write_Str --
 401    ---------------
 402
 403    procedure Write_Str (S : String) is
 404    begin
 405       for J in S'Range loop
 406          Write_Char (S (J));
 407       end loop;
 408    end Write_Str;
 409
 410 end Output;