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