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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Hostparm;
  29 with Namet;    use Namet;
  30 with Osint.C;  use Osint.C;
  31
  32 package body Lib.Util is
  33
  34    Max_Line   : constant Natural := 2 * Hostparm.Max_Name_Length + 64;
  35    Max_Buffer : constant Natural := 1000 * Max_Line;
  36
  37    Info_Buffer : String (1 .. Max_Buffer);
  38    --  Info_Buffer used to prepare lines of library output
  39
  40    Info_Buffer_Len : Natural := 0;
  41    --  Number of characters stored in Info_Buffer
  42
  43    Info_Buffer_Col : Natural := 1;
  44    --  Column number of next character to be written.
  45    --  Can be different from Info_Buffer_Len + 1
  46    --  because of tab characters written by Write_Info_Tab.
  47
  48    ---------------------
  49    -- Write_Info_Char --
  50    ---------------------
  51
  52    procedure Write_Info_Char (C : Character) is
  53    begin
  54       Info_Buffer_Len := Info_Buffer_Len + 1;
  55       Info_Buffer (Info_Buffer_Len) := C;
  56       Info_Buffer_Col := Info_Buffer_Col + 1;
  57    end Write_Info_Char;
  58
  59    --------------------------
  60    -- Write_Info_Char_Code --
  61    --------------------------
  62
  63    procedure Write_Info_Char_Code (Code : Char_Code) is
  64
  65       procedure Write_Info_Hex_Byte (J : Natural);
  66       --  Write single hex digit
  67
  68       procedure Write_Info_Hex_Byte (J : Natural) is
  69          Hexd : String := "0123456789abcdef";
  70
  71       begin
  72          Write_Info_Char (Hexd (J / 16 + 1));
  73          Write_Info_Char (Hexd (J mod 16 + 1));
  74       end Write_Info_Hex_Byte;
  75
  76    --  Start of processing for Write_Info_Char_Code
  77
  78    begin
  79       if Code in 16#00# .. 16#7F# then
  80          Write_Info_Char (Character'Val (Code));
  81
  82       elsif Code in 16#80# .. 16#FF# then
  83          Write_Info_Char ('U');
  84          Write_Info_Hex_Byte (Natural (Code));
  85
  86       else
  87          Write_Info_Char ('W');
  88          Write_Info_Hex_Byte (Natural (Code / 256));
  89          Write_Info_Hex_Byte (Natural (Code mod 256));
  90       end if;
  91    end Write_Info_Char_Code;
  92
  93    --------------------
  94    -- Write_Info_Col --
  95    --------------------
  96
  97    function Write_Info_Col return Positive is
  98    begin
  99       return Info_Buffer_Col;
 100    end Write_Info_Col;
 101
 102    --------------------
 103    -- Write_Info_EOL --
 104    --------------------
 105
 106    procedure Write_Info_EOL is
 107    begin
 108       if Hostparm.OpenVMS
 109         or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
 110       then
 111          Write_Info_Terminate;
 112       else
 113          --  Delete any trailing blanks
 114
 115          while Info_Buffer_Len > 0
 116            and then Info_Buffer (Info_Buffer_Len) = ' '
 117          loop
 118             Info_Buffer_Len := Info_Buffer_Len - 1;
 119          end loop;
 120
 121          Info_Buffer_Len := Info_Buffer_Len + 1;
 122          Info_Buffer (Info_Buffer_Len) := ASCII.LF;
 123          Info_Buffer_Col := 1;
 124       end if;
 125    end Write_Info_EOL;
 126
 127    -------------------------
 128    -- Write_Info_Initiate --
 129    -------------------------
 130
 131    procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
 132
 133    ---------------------
 134    -- Write_Info_Name --
 135    ---------------------
 136
 137    procedure Write_Info_Name (Name : Name_Id) is
 138    begin
 139       Get_Name_String (Name);
 140       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 141         Name_Buffer (1 .. Name_Len);
 142       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 143       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 144    end Write_Info_Name;
 145
 146    --------------------
 147    -- Write_Info_Nat --
 148    --------------------
 149
 150    procedure Write_Info_Nat (N : Nat) is
 151    begin
 152       if N > 9 then
 153          Write_Info_Nat (N / 10);
 154       end if;
 155
 156       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
 157    end Write_Info_Nat;
 158
 159    --------------------
 160    -- Write_Info_Str --
 161    --------------------
 162
 163    procedure Write_Info_Str (Val : String) is
 164    begin
 165       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
 166                                                                   := Val;
 167       Info_Buffer_Len := Info_Buffer_Len + Val'Length;
 168       Info_Buffer_Col := Info_Buffer_Col + Val'Length;
 169    end Write_Info_Str;
 170
 171    --------------------
 172    -- Write_Info_Tab --
 173    --------------------
 174
 175    procedure Write_Info_Tab (Col : Positive) is
 176       Next_Tab : Positive;
 177
 178    begin
 179       if Col <= Info_Buffer_Col then
 180          Write_Info_Str ("  ");
 181       else
 182          loop
 183             Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
 184             exit when Col < Next_Tab;
 185             Write_Info_Char (ASCII.HT);
 186             Info_Buffer_Col := Next_Tab;
 187          end loop;
 188
 189          while Info_Buffer_Col < Col loop
 190             Write_Info_Char (' ');
 191          end loop;
 192       end if;
 193    end Write_Info_Tab;
 194
 195    --------------------------
 196    -- Write_Info_Terminate --
 197    --------------------------
 198
 199    procedure Write_Info_Terminate is
 200    begin
 201       --  Delete any trailing blanks
 202
 203       while Info_Buffer_Len > 0
 204         and then Info_Buffer (Info_Buffer_Len) = ' '
 205       loop
 206          Info_Buffer_Len := Info_Buffer_Len - 1;
 207       end loop;
 208
 209       --  Write_Library_Info adds the EOL
 210
 211       Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
 212
 213       Info_Buffer_Len := 0;
 214       Info_Buffer_Col := 1;
 215
 216    end Write_Info_Terminate;
 217
 218 end Lib.Util;