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-2017, 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 package body Output is
  33
  34    Buffer : String (1 .. Buffer_Max + 1) := (others => '*');
  35    for Buffer'Alignment use 4;
  36    --  Buffer used to build output line. We do line buffering because it is
  37    --  needed for the support of the debug-generated-code option (-gnatD). Note
  38    --  any attempt to write more output to a line than can fit in the buffer
  39    --  will be silently ignored. The alignment clause improves the efficiency
  40    --  of the save/restore procedures.
  41
  42    Next_Col : Positive range 1 .. Buffer'Length + 1 := 1;
  43    --  Column about to be written
  44
  45    Current_FD : File_Descriptor := Standout;
  46    --  File descriptor for current output
  47
  48    Special_Output_Proc : Output_Proc := null;
  49    --  Record argument to last call to Set_Special_Output. If this is
  50    --  non-null, then we are in special output mode.
  51
  52    Indentation_Amount : constant Positive := 3;
  53    --  Number of spaces to output for each indentation level
  54
  55    Indentation_Limit : constant Positive := 40;
  56    --  Indentation beyond this number of spaces wraps around
  57
  58    --  Disable the warnings emitted by -gnatwc because the comparison within
  59    --  the assertion depends on conditional compilation.
  60
  61    pragma Warnings (Off, "condition can only be * if invalid values present");
  62    pragma Assert (Indentation_Limit < Buffer_Max / 2);
  63    pragma Warnings (On,  "condition can only be * if invalid values present");
  64    --  Make sure this is substantially shorter than the line length
  65
  66    Cur_Indentation : Natural := 0;
  67    --  Number of spaces to indent each line
  68
  69    -----------------------
  70    -- Local_Subprograms --
  71    -----------------------
  72
  73    procedure Flush_Buffer;
  74    --  Flush buffer if non-empty and reset column counter
  75
  76    ---------------------------
  77    -- Cancel_Special_Output --
  78    ---------------------------
  79
  80    procedure Cancel_Special_Output is
  81    begin
  82       Special_Output_Proc := null;
  83    end Cancel_Special_Output;
  84
  85    ------------
  86    -- Column --
  87    ------------
  88
  89    function Column return Pos is
  90    begin
  91       return Pos (Next_Col);
  92    end Column;
  93
  94    ----------------------
  95    -- Delete_Last_Char --
  96    ----------------------
  97
  98    procedure Delete_Last_Char is
  99    begin
 100       if Next_Col /= 1 then
 101          Next_Col := Next_Col - 1;
 102       end if;
 103    end Delete_Last_Char;
 104
 105    ------------------
 106    -- Flush_Buffer --
 107    ------------------
 108
 109    procedure Flush_Buffer is
 110       Write_Error : exception;
 111       --  Raised if Write fails
 112
 113       ------------------
 114       -- Write_Buffer --
 115       ------------------
 116
 117       procedure Write_Buffer (Buf : String);
 118       --  Write out Buf, either using Special_Output_Proc, or the normal way
 119       --  using Write. Raise Write_Error if Write fails (presumably due to disk
 120       --  full). Write_Error is not used in the case of Special_Output_Proc.
 121
 122       procedure Write_Buffer (Buf : String) is
 123       begin
 124          --  If Special_Output_Proc has been set, then use it
 125
 126          if Special_Output_Proc /= null then
 127             Special_Output_Proc.all (Buf);
 128
 129          --  If output is not set, then output to either standard output
 130          --  or standard error.
 131
 132          elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then
 133             raise Write_Error;
 134
 135          end if;
 136       end Write_Buffer;
 137
 138       Len : constant Natural := Next_Col - 1;
 139
 140    --  Start of processing for Flush_Buffer
 141
 142    begin
 143       if Len /= 0 then
 144          begin
 145             --  If there's no indentation, or if the line is too long with
 146             --  indentation, or if it's a blank line, just write the buffer.
 147
 148             if Cur_Indentation = 0
 149               or else Cur_Indentation + Len > Buffer_Max
 150               or else Buffer (1 .. Len) = (1 => ASCII.LF)
 151             then
 152                Write_Buffer (Buffer (1 .. Len));
 153
 154             --  Otherwise, construct a new buffer with preceding spaces, and
 155             --  write that.
 156
 157             else
 158                declare
 159                   Indented_Buffer : constant String :=
 160                                       (1 .. Cur_Indentation => ' ') &
 161                                                           Buffer (1 .. Len);
 162                begin
 163                   Write_Buffer (Indented_Buffer);
 164                end;
 165             end if;
 166
 167          exception
 168             when Write_Error =>
 169
 170                --  If there are errors with standard error just quit. Otherwise
 171                --  set the output to standard error before reporting a failure
 172                --  and quitting.
 173
 174                if Current_FD /= Standerr then
 175                   Current_FD := Standerr;
 176                   Next_Col := 1;
 177                   Write_Line ("fatal error: disk full");
 178                end if;
 179
 180                OS_Exit (2);
 181          end;
 182
 183          --  Buffer is now empty
 184
 185          Next_Col := 1;
 186       end if;
 187    end Flush_Buffer;
 188
 189    -------------------
 190    -- Ignore_Output --
 191    -------------------
 192
 193    procedure Ignore_Output (S : String) is
 194    begin
 195       null;
 196    end Ignore_Output;
 197
 198    ------------
 199    -- Indent --
 200    ------------
 201
 202    procedure Indent is
 203    begin
 204       --  The "mod" in the following assignment is to cause a wrap around in
 205       --  the case where there is too much indentation.
 206
 207       Cur_Indentation :=
 208         (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
 209    end Indent;
 210
 211    ---------------
 212    -- Last_Char --
 213    ---------------
 214
 215    function Last_Char return Character is
 216    begin
 217       if Next_Col /= 1 then
 218          return Buffer (Next_Col - 1);
 219       else
 220          return ASCII.NUL;
 221       end if;
 222    end Last_Char;
 223
 224    -------------
 225    -- Outdent --
 226    -------------
 227
 228    procedure Outdent is
 229    begin
 230       --  The "mod" here undoes the wrap around from Indent above
 231
 232       Cur_Indentation :=
 233         (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
 234    end Outdent;
 235
 236    ---------------------------
 237    -- Restore_Output_Buffer --
 238    ---------------------------
 239
 240    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
 241    begin
 242       Next_Col := S.Next_Col;
 243       Cur_Indentation := S.Cur_Indentation;
 244       Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
 245    end Restore_Output_Buffer;
 246
 247    ------------------------
 248    -- Save_Output_Buffer --
 249    ------------------------
 250
 251    function Save_Output_Buffer return Saved_Output_Buffer is
 252       S : Saved_Output_Buffer;
 253    begin
 254       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
 255       S.Next_Col := Next_Col;
 256       S.Cur_Indentation := Cur_Indentation;
 257       Next_Col := 1;
 258       Cur_Indentation := 0;
 259       return S;
 260    end Save_Output_Buffer;
 261
 262    ------------------------
 263    -- Set_Special_Output --
 264    ------------------------
 265
 266    procedure Set_Special_Output (P : Output_Proc) is
 267    begin
 268       Special_Output_Proc := P;
 269    end Set_Special_Output;
 270
 271    ----------------
 272    -- Set_Output --
 273    ----------------
 274
 275    procedure Set_Output (FD : File_Descriptor) is
 276    begin
 277       if Special_Output_Proc = null then
 278          Flush_Buffer;
 279       end if;
 280
 281       Current_FD := FD;
 282    end Set_Output;
 283
 284    ------------------------
 285    -- Set_Standard_Error --
 286    ------------------------
 287
 288    procedure Set_Standard_Error is
 289    begin
 290       Set_Output (Standerr);
 291    end Set_Standard_Error;
 292
 293    -------------------------
 294    -- Set_Standard_Output --
 295    -------------------------
 296
 297    procedure Set_Standard_Output is
 298    begin
 299       Set_Output (Standout);
 300    end Set_Standard_Output;
 301
 302    -------
 303    -- w --
 304    -------
 305
 306    procedure w (C : Character) is
 307    begin
 308       Write_Char (''');
 309       Write_Char (C);
 310       Write_Char (''');
 311       Write_Eol;
 312    end w;
 313
 314    procedure w (S : String) is
 315    begin
 316       Write_Str (S);
 317       Write_Eol;
 318    end w;
 319
 320    procedure w (V : Int) is
 321    begin
 322       Write_Int (V);
 323       Write_Eol;
 324    end w;
 325
 326    procedure w (B : Boolean) is
 327    begin
 328       if B then
 329          w ("True");
 330       else
 331          w ("False");
 332       end if;
 333    end w;
 334
 335    procedure w (L : String; C : Character) is
 336    begin
 337       Write_Str (L);
 338       Write_Char (' ');
 339       w (C);
 340    end w;
 341
 342    procedure w (L : String; S : String) is
 343    begin
 344       Write_Str (L);
 345       Write_Char (' ');
 346       w (S);
 347    end w;
 348
 349    procedure w (L : String; V : Int) is
 350    begin
 351       Write_Str (L);
 352       Write_Char (' ');
 353       w (V);
 354    end w;
 355
 356    procedure w (L : String; B : Boolean) is
 357    begin
 358       Write_Str (L);
 359       Write_Char (' ');
 360       w (B);
 361    end w;
 362
 363    ----------------
 364    -- Write_Char --
 365    ----------------
 366
 367    procedure Write_Char (C : Character) is
 368    begin
 369       pragma Assert (Next_Col in Buffer'Range);
 370       if Next_Col = Buffer'Length then
 371          Write_Eol;
 372       end if;
 373
 374       if C = ASCII.LF then
 375          Write_Eol;
 376       else
 377          Buffer (Next_Col) := C;
 378          Next_Col := Next_Col + 1;
 379       end if;
 380    end Write_Char;
 381
 382    ---------------
 383    -- Write_Eol --
 384    ---------------
 385
 386    procedure Write_Eol is
 387    begin
 388       --  Remove any trailing spaces
 389
 390       while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
 391          Next_Col := Next_Col - 1;
 392       end loop;
 393
 394       Buffer (Next_Col) := ASCII.LF;
 395       Next_Col := Next_Col + 1;
 396       Flush_Buffer;
 397    end Write_Eol;
 398
 399    ---------------------------
 400    -- Write_Eol_Keep_Blanks --
 401    ---------------------------
 402
 403    procedure Write_Eol_Keep_Blanks is
 404    begin
 405       Buffer (Next_Col) := ASCII.LF;
 406       Next_Col := Next_Col + 1;
 407       Flush_Buffer;
 408    end Write_Eol_Keep_Blanks;
 409
 410    ----------------------
 411    -- Write_Erase_Char --
 412    ----------------------
 413
 414    procedure Write_Erase_Char (C : Character) is
 415    begin
 416       if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
 417          Next_Col := Next_Col - 1;
 418       end if;
 419    end Write_Erase_Char;
 420
 421    ---------------
 422    -- Write_Int --
 423    ---------------
 424
 425    procedure Write_Int (Val : Int) is
 426       --  Type Int has one extra negative number (i.e. two's complement), so we
 427       --  work with negative numbers here. Otherwise, negating Int'First will
 428       --  overflow.
 429
 430       subtype Nonpositive is Int range Int'First .. 0;
 431       procedure Write_Abs (Val : Nonpositive);
 432       --  Write out the absolute value of Val
 433
 434       procedure Write_Abs (Val : Nonpositive) is
 435       begin
 436          if Val < -9 then
 437             Write_Abs (Val / 10); -- Recursively write higher digits
 438          end if;
 439
 440          Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0')));
 441       end Write_Abs;
 442
 443    begin
 444       if Val < 0 then
 445          Write_Char ('-');
 446          Write_Abs (Val);
 447       else
 448          Write_Abs (-Val);
 449       end if;
 450    end Write_Int;
 451
 452    ----------------
 453    -- Write_Line --
 454    ----------------
 455
 456    procedure Write_Line (S : String) is
 457    begin
 458       Write_Str (S);
 459       Write_Eol;
 460    end Write_Line;
 461
 462    ------------------
 463    -- Write_Spaces --
 464    ------------------
 465
 466    procedure Write_Spaces (N : Nat) is
 467    begin
 468       for J in 1 .. N loop
 469          Write_Char (' ');
 470       end loop;
 471    end Write_Spaces;
 472
 473    ---------------
 474    -- Write_Str --
 475    ---------------
 476
 477    procedure Write_Str (S : String) is
 478    begin
 479       for J in S'Range loop
 480          Write_Char (S (J));
 481       end loop;
 482    end Write_Str;
 483
 484 end Output;