gcc/ada/lib-util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             L I B . U T I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Hostparm;
  28 with Osint.C;  use Osint.C;
  29
  30 package body Lib.Util is
  31
  32    Max_Line   : constant Natural := 2 * Hostparm.Max_Name_Length + 64;
  33    Max_Buffer : constant Natural := 1000 * Max_Line;
  34
  35    Info_Buffer : String (1 .. Max_Buffer);
  36    --  Info_Buffer used to prepare lines of library output
  37
  38    Info_Buffer_Len : Natural := 0;
  39    --  Number of characters stored in Info_Buffer
  40
  41    Info_Buffer_Col : Natural := 1;
  42    --  Column number of next character to be written.
  43    --  Can be different from Info_Buffer_Len + 1
  44    --  because of tab characters written by Write_Info_Tab.
  45
  46    ---------------------
  47    -- Write_Info_Char --
  48    ---------------------
  49
  50    procedure Write_Info_Char (C : Character) is
  51    begin
  52       Info_Buffer_Len := Info_Buffer_Len + 1;
  53       Info_Buffer (Info_Buffer_Len) := C;
  54       Info_Buffer_Col := Info_Buffer_Col + 1;
  55    end Write_Info_Char;
  56
  57    --------------------------
  58    -- Write_Info_Char_Code --
  59    --------------------------
  60
  61    procedure Write_Info_Char_Code (Code : Char_Code) is
  62
  63       procedure Write_Info_Hex_Byte (J : Natural);
  64       --  Write single hex digit
  65
  66       procedure Write_Info_Hex_Byte (J : Natural) is
  67          Hexd : constant String := "0123456789abcdef";
  68
  69       begin
  70          Write_Info_Char (Hexd (J / 16 + 1));
  71          Write_Info_Char (Hexd (J mod 16 + 1));
  72       end Write_Info_Hex_Byte;
  73
  74    --  Start of processing for Write_Info_Char_Code
  75
  76    begin
  77       --  00 .. 7F
  78
  79       if Code <= 16#7F# then
  80          Write_Info_Char (Character'Val (Code));
  81
  82       --  80 .. FF
  83
  84       elsif Code <= 16#FF# then
  85          Write_Info_Char ('U');
  86          Write_Info_Hex_Byte (Natural (Code));
  87
  88       --  0100 .. FFFF
  89
  90       else
  91          Write_Info_Char ('W');
  92          Write_Info_Hex_Byte (Natural (Code / 256));
  93          Write_Info_Hex_Byte (Natural (Code mod 256));
  94       end if;
  95    end Write_Info_Char_Code;
  96
  97    --------------------
  98    -- Write_Info_Col --
  99    --------------------
 100
 101    function Write_Info_Col return Positive is
 102    begin
 103       return Info_Buffer_Col;
 104    end Write_Info_Col;
 105
 106    --------------------
 107    -- Write_Info_EOL --
 108    --------------------
 109
 110    procedure Write_Info_EOL is
 111    begin
 112       if Hostparm.OpenVMS
 113         or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
 114       then
 115          Write_Info_Terminate;
 116       else
 117          --  Delete any trailing blanks
 118
 119          while Info_Buffer_Len > 0
 120            and then Info_Buffer (Info_Buffer_Len) = ' '
 121          loop
 122             Info_Buffer_Len := Info_Buffer_Len - 1;
 123          end loop;
 124
 125          Info_Buffer_Len := Info_Buffer_Len + 1;
 126          Info_Buffer (Info_Buffer_Len) := ASCII.LF;
 127          Info_Buffer_Col := 1;
 128       end if;
 129    end Write_Info_EOL;
 130
 131    -------------------------
 132    -- Write_Info_Initiate --
 133    -------------------------
 134
 135    procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
 136
 137    ---------------------
 138    -- Write_Info_Name --
 139    ---------------------
 140
 141    procedure Write_Info_Name (Name : Name_Id) is
 142    begin
 143       Get_Name_String (Name);
 144       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 145         Name_Buffer (1 .. Name_Len);
 146       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 147       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 148    end Write_Info_Name;
 149
 150    procedure Write_Info_Name (Name : File_Name_Type) is
 151    begin
 152       Write_Info_Name (Name_Id (Name));
 153    end Write_Info_Name;
 154
 155    procedure Write_Info_Name (Name : Unit_Name_Type) is
 156    begin
 157       Write_Info_Name (Name_Id (Name));
 158    end Write_Info_Name;
 159
 160    --------------------
 161    -- Write_Info_Nat --
 162    --------------------
 163
 164    procedure Write_Info_Nat (N : Nat) is
 165    begin
 166       if N > 9 then
 167          Write_Info_Nat (N / 10);
 168       end if;
 169
 170       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
 171    end Write_Info_Nat;
 172
 173    --------------------
 174    -- Write_Info_Str --
 175    --------------------
 176
 177    procedure Write_Info_Str (Val : String) is
 178    begin
 179       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
 180                                                                   := Val;
 181       Info_Buffer_Len := Info_Buffer_Len + Val'Length;
 182       Info_Buffer_Col := Info_Buffer_Col + Val'Length;
 183    end Write_Info_Str;
 184
 185    --------------------
 186    -- Write_Info_Tab --
 187    --------------------
 188
 189    procedure Write_Info_Tab (Col : Positive) is
 190       Next_Tab : Positive;
 191
 192    begin
 193       if Col <= Info_Buffer_Col then
 194          Write_Info_Str ("  ");
 195       else
 196          loop
 197             Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
 198             exit when Col < Next_Tab;
 199             Write_Info_Char (ASCII.HT);
 200             Info_Buffer_Col := Next_Tab;
 201          end loop;
 202
 203          while Info_Buffer_Col < Col loop
 204             Write_Info_Char (' ');
 205          end loop;
 206       end if;
 207    end Write_Info_Tab;
 208
 209    --------------------------
 210    -- Write_Info_Terminate --
 211    --------------------------
 212
 213    procedure Write_Info_Terminate is
 214    begin
 215       --  Delete any trailing blanks
 216
 217       while Info_Buffer_Len > 0
 218         and then Info_Buffer (Info_Buffer_Len) = ' '
 219       loop
 220          Info_Buffer_Len := Info_Buffer_Len - 1;
 221       end loop;
 222
 223       --  Write_Library_Info adds the EOL
 224
 225       Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
 226
 227       Info_Buffer_Len := 0;
 228       Info_Buffer_Col := 1;
 229
 230    end Write_Info_Terminate;
 231
 232 end Lib.Util;