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