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