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