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-2023, 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       Flush_Buffer;
 239       pragma Assert (FD_Stack_Idx >= FD_Array'First);
 240       Current_FD := FD_Stack (FD_Stack_Idx);
 241       FD_Stack_Idx := FD_Stack_Idx - 1;
 242    end Pop_Output;
 243
 244    -----------------
 245    -- Push_Output --
 246    -----------------
 247
 248    procedure Push_Output is
 249    begin
 250       pragma Assert (FD_Stack_Idx < FD_Array'Last);
 251       FD_Stack_Idx := FD_Stack_Idx + 1;
 252       FD_Stack (FD_Stack_Idx) := Current_FD;
 253    end Push_Output;
 254
 255    ---------------------------
 256    -- Restore_Output_Buffer --
 257    ---------------------------
 258
 259    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
 260    begin
 261       Next_Col := S.Next_Col;
 262       Cur_Indentation := S.Cur_Indentation;
 263       Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
 264    end Restore_Output_Buffer;
 265
 266    ------------------------
 267    -- Save_Output_Buffer --
 268    ------------------------
 269
 270    function Save_Output_Buffer return Saved_Output_Buffer is
 271       S : Saved_Output_Buffer;
 272    begin
 273       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
 274       S.Next_Col := Next_Col;
 275       S.Cur_Indentation := Cur_Indentation;
 276       Next_Col := 1;
 277       Cur_Indentation := 0;
 278       return S;
 279    end Save_Output_Buffer;
 280
 281    ------------------------
 282    -- Set_Special_Output --
 283    ------------------------
 284
 285    procedure Set_Special_Output (P : Output_Proc) is
 286    begin
 287       Special_Output_Proc := P;
 288    end Set_Special_Output;
 289
 290    ----------------
 291    -- Set_Output --
 292    ----------------
 293
 294    procedure Set_Output (FD : File_Descriptor) is
 295    begin
 296       Flush_Buffer;
 297       Current_FD := FD;
 298    end Set_Output;
 299
 300    ------------------------
 301    -- Set_Standard_Error --
 302    ------------------------
 303
 304    procedure Set_Standard_Error is
 305    begin
 306       Set_Output (Standerr);
 307    end Set_Standard_Error;
 308
 309    -------------------------
 310    -- Set_Standard_Output --
 311    -------------------------
 312
 313    procedure Set_Standard_Output is
 314    begin
 315       Set_Output (Standout);
 316    end Set_Standard_Output;
 317
 318    -------
 319    -- w --
 320    -------
 321
 322    procedure w (C : Character) is
 323    begin
 324       Push_Output;
 325       Set_Standard_Error;
 326
 327       Write_Char (''');
 328       Write_Char (C);
 329       Write_Char (''');
 330       Write_Eol;
 331
 332       Pop_Output;
 333    end w;
 334
 335    procedure w (S : String) is
 336    begin
 337       Push_Output;
 338       Set_Standard_Error;
 339
 340       Write_Str (S);
 341       Write_Eol;
 342
 343       Pop_Output;
 344    end w;
 345
 346    procedure w (V : Int) is
 347    begin
 348       Push_Output;
 349       Set_Standard_Error;
 350
 351       Write_Int (V);
 352       Write_Eol;
 353
 354       Pop_Output;
 355    end w;
 356
 357    procedure w (B : Boolean) is
 358    begin
 359       Push_Output;
 360       Set_Standard_Error;
 361
 362       if B then
 363          w ("True");
 364       else
 365          w ("False");
 366       end if;
 367
 368       Pop_Output;
 369    end w;
 370
 371    procedure w (L : String; C : Character) is
 372    begin
 373       Push_Output;
 374       Set_Standard_Error;
 375
 376       Write_Str (L);
 377       Write_Char (' ');
 378       w (C);
 379
 380       Pop_Output;
 381    end w;
 382
 383    procedure w (L : String; S : String) is
 384    begin
 385       Push_Output;
 386       Set_Standard_Error;
 387
 388       Write_Str (L);
 389       Write_Char (' ');
 390       w (S);
 391
 392       Pop_Output;
 393    end w;
 394
 395    procedure w (L : String; V : Int) is
 396    begin
 397       Push_Output;
 398       Set_Standard_Error;
 399
 400       Write_Str (L);
 401       Write_Char (' ');
 402       w (V);
 403
 404       Pop_Output;
 405    end w;
 406
 407    procedure w (L : String; B : Boolean) is
 408    begin
 409       Push_Output;
 410       Set_Standard_Error;
 411
 412       Write_Str (L);
 413       Write_Char (' ');
 414       w (B);
 415
 416       Pop_Output;
 417    end w;
 418
 419    ----------------
 420    -- Write_Char --
 421    ----------------
 422
 423    procedure Write_Char (C : Character) is
 424    begin
 425       if Next_Col > Buffer'Length then
 426          Flush_Buffer;
 427       end if;
 428       pragma Assert (Next_Col in Buffer'Range);
 429
 430       if C = ASCII.LF then
 431          Write_Eol;
 432       else
 433          Buffer (Next_Col) := C;
 434          Next_Col := Next_Col + 1;
 435       end if;
 436    end Write_Char;
 437
 438    ---------------
 439    -- Write_Eol --
 440    ---------------
 441
 442    procedure Write_Eol is
 443    begin
 444       --  Remove any trailing spaces
 445
 446       while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
 447          Next_Col := Next_Col - 1;
 448       end loop;
 449
 450       Buffer (Next_Col) := ASCII.LF;
 451       Next_Col := Next_Col + 1;
 452       Flush_Buffer;
 453    end Write_Eol;
 454
 455    ---------------------------
 456    -- Write_Eol_Keep_Blanks --
 457    ---------------------------
 458
 459    procedure Write_Eol_Keep_Blanks is
 460    begin
 461       Buffer (Next_Col) := ASCII.LF;
 462       Next_Col := Next_Col + 1;
 463       Flush_Buffer;
 464    end Write_Eol_Keep_Blanks;
 465
 466    ----------------------
 467    -- Write_Erase_Char --
 468    ----------------------
 469
 470    procedure Write_Erase_Char (C : Character) is
 471    begin
 472       if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
 473          Next_Col := Next_Col - 1;
 474       end if;
 475    end Write_Erase_Char;
 476
 477    ---------------
 478    -- Write_Int --
 479    ---------------
 480
 481    procedure Write_Int (Val : Int) is
 482       --  Type Int has one extra negative number (i.e. two's complement), so we
 483       --  work with negative numbers here. Otherwise, negating Int'First will
 484       --  overflow.
 485
 486       subtype Nonpositive is Int range Int'First .. 0;
 487       procedure Write_Abs (Val : Nonpositive);
 488       --  Write out the absolute value of Val
 489
 490       procedure Write_Abs (Val : Nonpositive) is
 491       begin
 492          if Val < -9 then
 493             Write_Abs (Val / 10); -- Recursively write higher digits
 494          end if;
 495
 496          Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0')));
 497       end Write_Abs;
 498
 499    begin
 500       if Val < 0 then
 501          Write_Char ('-');
 502          Write_Abs (Val);
 503       else
 504          Write_Abs (-Val);
 505       end if;
 506    end Write_Int;
 507
 508    ------------------
 509    -- Write_Int_64 --
 510    ------------------
 511
 512    procedure Write_Int_64 (Val : Int_64) is
 513       subtype Nonpositive is Int_64 range Int_64'First .. 0;
 514       procedure Write_Abs (Val : Nonpositive);
 515
 516       procedure Write_Abs (Val : Nonpositive) is
 517       begin
 518          if Val < -9 then
 519             Write_Abs (Val / 10);
 520          end if;
 521
 522          Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0')));
 523       end Write_Abs;
 524
 525    begin
 526       if Val < 0 then
 527          Write_Char ('-');
 528          Write_Abs (Val);
 529       else
 530          Write_Abs (-Val);
 531       end if;
 532    end Write_Int_64;
 533
 534    ----------------
 535    -- Write_Line --
 536    ----------------
 537
 538    procedure Write_Line (S : String) is
 539    begin
 540       Write_Str (S);
 541       Write_Eol;
 542    end Write_Line;
 543
 544    ------------------
 545    -- Write_Spaces --
 546    ------------------
 547
 548    procedure Write_Spaces (N : Nat) is
 549    begin
 550       for J in 1 .. N loop
 551          Write_Char (' ');
 552       end loop;
 553    end Write_Spaces;
 554
 555    ---------------
 556    -- Write_Str --
 557    ---------------
 558
 559    procedure Write_Str (S : String) is
 560    begin
 561       for J in S'Range loop
 562          Write_Char (S (J));
 563       end loop;
 564    end Write_Str;
 565
 566 end Output;