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       --  The "mod" in the following assignment is to cause a wrap around in
 166       --  the case where there is too much indentation.
 167
 168       Cur_Indentation :=
 169         (Cur_Indentation + Indentation_Amount) mod Indentation_Limit;
 170    end Indent;
 171
 172    -------------
 173    -- Outdent --
 174    -------------
 175
 176    procedure Outdent is
 177    begin
 178       --  The "mod" here undoes the wrap around from Indent above
 179
 180       Cur_Indentation :=
 181         (Cur_Indentation - Indentation_Amount) mod Indentation_Limit;
 182    end Outdent;
 183
 184    ---------------------------
 185    -- Restore_Output_Buffer --
 186    ---------------------------
 187
 188    procedure Restore_Output_Buffer (S : Saved_Output_Buffer) is
 189    begin
 190       Next_Col := S.Next_Col;
 191       Cur_Indentation := S.Cur_Indentation;
 192       Buffer (1 .. Next_Col - 1) := S.Buffer (1 .. Next_Col - 1);
 193    end Restore_Output_Buffer;
 194
 195    ------------------------
 196    -- Save_Output_Buffer --
 197    ------------------------
 198
 199    function Save_Output_Buffer return Saved_Output_Buffer is
 200       S : Saved_Output_Buffer;
 201    begin
 202       S.Buffer (1 .. Next_Col - 1) := Buffer (1 .. Next_Col - 1);
 203       S.Next_Col := Next_Col;
 204       S.Cur_Indentation := Cur_Indentation;
 205       Next_Col := 1;
 206       Cur_Indentation := 0;
 207       return S;
 208    end Save_Output_Buffer;
 209
 210    ------------------------
 211    -- Set_Special_Output --
 212    ------------------------
 213
 214    procedure Set_Special_Output (P : Output_Proc) is
 215    begin
 216       Special_Output_Proc := P;
 217    end Set_Special_Output;
 218
 219    ------------------------
 220    -- Set_Standard_Error --
 221    ------------------------
 222
 223    procedure Set_Standard_Error is
 224    begin
 225       if Special_Output_Proc = null then
 226          Flush_Buffer;
 227       end if;
 228
 229       Current_FD := Standerr;
 230    end Set_Standard_Error;
 231
 232    -------------------------
 233    -- Set_Standard_Output --
 234    -------------------------
 235
 236    procedure Set_Standard_Output is
 237    begin
 238       if Special_Output_Proc = null then
 239          Flush_Buffer;
 240       end if;
 241
 242       Current_FD := Standout;
 243    end Set_Standard_Output;
 244
 245    -------
 246    -- w --
 247    -------
 248
 249    procedure w (C : Character) is
 250    begin
 251       Write_Char (''');
 252       Write_Char (C);
 253       Write_Char (''');
 254       Write_Eol;
 255    end w;
 256
 257    procedure w (S : String) is
 258    begin
 259       Write_Str (S);
 260       Write_Eol;
 261    end w;
 262
 263    procedure w (V : Int) is
 264    begin
 265       Write_Int (V);
 266       Write_Eol;
 267    end w;
 268
 269    procedure w (B : Boolean) is
 270    begin
 271       if B then
 272          w ("True");
 273       else
 274          w ("False");
 275       end if;
 276    end w;
 277
 278    procedure w (L : String; C : Character) is
 279    begin
 280       Write_Str (L);
 281       Write_Char (' ');
 282       w (C);
 283    end w;
 284
 285    procedure w (L : String; S : String) is
 286    begin
 287       Write_Str (L);
 288       Write_Char (' ');
 289       w (S);
 290    end w;
 291
 292    procedure w (L : String; V : Int) is
 293    begin
 294       Write_Str (L);
 295       Write_Char (' ');
 296       w (V);
 297    end w;
 298
 299    procedure w (L : String; B : Boolean) is
 300    begin
 301       Write_Str (L);
 302       Write_Char (' ');
 303       w (B);
 304    end w;
 305
 306    ----------------
 307    -- Write_Char --
 308    ----------------
 309
 310    procedure Write_Char (C : Character) is
 311    begin
 312       if Next_Col = Buffer'Length then
 313          Write_Eol;
 314       end if;
 315
 316       if C = ASCII.LF then
 317          Write_Eol;
 318       else
 319          Buffer (Next_Col) := C;
 320          Next_Col := Next_Col + 1;
 321       end if;
 322    end Write_Char;
 323
 324    ---------------
 325    -- Write_Eol --
 326    ---------------
 327
 328    procedure Write_Eol is
 329    begin
 330       --  Remove any trailing space
 331
 332       while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop
 333          Next_Col := Next_Col - 1;
 334       end loop;
 335
 336       Buffer (Next_Col) := ASCII.LF;
 337       Next_Col := Next_Col + 1;
 338       Flush_Buffer;
 339    end Write_Eol;
 340
 341    ---------------------------
 342    -- Write_Eol_Keep_Blanks --
 343    ---------------------------
 344
 345    procedure Write_Eol_Keep_Blanks is
 346    begin
 347       Buffer (Next_Col) := ASCII.LF;
 348       Next_Col := Next_Col + 1;
 349       Flush_Buffer;
 350    end Write_Eol_Keep_Blanks;
 351
 352    ----------------------
 353    -- Write_Erase_Char --
 354    ----------------------
 355
 356    procedure Write_Erase_Char (C : Character) is
 357    begin
 358       if Next_Col /= 1 and then Buffer (Next_Col - 1) = C then
 359          Next_Col := Next_Col - 1;
 360       end if;
 361    end Write_Erase_Char;
 362
 363    ---------------
 364    -- Write_Int --
 365    ---------------
 366
 367    procedure Write_Int (Val : Int) is
 368    begin
 369       if Val < 0 then
 370          Write_Char ('-');
 371          Write_Int (-Val);
 372
 373       else
 374          if Val > 9 then
 375             Write_Int (Val / 10);
 376          end if;
 377
 378          Write_Char (Character'Val ((Val mod 10) + Character'Pos ('0')));
 379       end if;
 380    end Write_Int;
 381
 382    ----------------
 383    -- Write_Line --
 384    ----------------
 385
 386    procedure Write_Line (S : String) is
 387    begin
 388       Write_Str (S);
 389       Write_Eol;
 390    end Write_Line;
 391
 392    ------------------
 393    -- Write_Spaces --
 394    ------------------
 395
 396    procedure Write_Spaces (N : Nat) is
 397    begin
 398       for J in 1 .. N loop
 399          Write_Char (' ');
 400       end loop;
 401    end Write_Spaces;
 402
 403    ---------------
 404    -- Write_Str --
 405    ---------------
 406
 407    procedure Write_Str (S : String) is
 408    begin
 409       for J in S'Range loop
 410          Write_Char (S (J));
 411       end loop;
 412    end Write_Str;
 413
 414 end Output;