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