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-2009, 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 with Stringt;  use Stringt;
  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 because of tab characters
  44    --  written by Write_Info_Tab.
  45
  46    procedure Write_Info_Hex_Byte (J : Natural);
  47    --  Place two hex digits representing the value J (which is in the range
  48    --  0-255) in Info_Buffer, incrementing Info_Buffer_Len by 2. The digits
  49    --  are output using lower case letters.
  50
  51    ---------------------
  52    -- Write_Info_Char --
  53    ---------------------
  54
  55    procedure Write_Info_Char (C : Character) is
  56    begin
  57       Info_Buffer_Len := Info_Buffer_Len + 1;
  58       Info_Buffer (Info_Buffer_Len) := C;
  59       Info_Buffer_Col := Info_Buffer_Col + 1;
  60    end Write_Info_Char;
  61
  62    --------------------------
  63    -- Write_Info_Char_Code --
  64    --------------------------
  65
  66    procedure Write_Info_Char_Code (Code : Char_Code) is
  67    begin
  68       --  00 .. 7F
  69
  70       if Code <= 16#7F# then
  71          Write_Info_Char (Character'Val (Code));
  72
  73       --  80 .. FF
  74
  75       elsif Code <= 16#FF# then
  76          Write_Info_Char ('U');
  77          Write_Info_Hex_Byte (Natural (Code));
  78
  79       --  0100 .. FFFF
  80
  81       else
  82          Write_Info_Char ('W');
  83          Write_Info_Hex_Byte (Natural (Code / 256));
  84          Write_Info_Hex_Byte (Natural (Code mod 256));
  85       end if;
  86    end Write_Info_Char_Code;
  87
  88    --------------------
  89    -- Write_Info_Col --
  90    --------------------
  91
  92    function Write_Info_Col return Positive is
  93    begin
  94       return Info_Buffer_Col;
  95    end Write_Info_Col;
  96
  97    --------------------
  98    -- Write_Info_EOL --
  99    --------------------
 100
 101    procedure Write_Info_EOL is
 102    begin
 103       if Hostparm.OpenVMS
 104         or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
 105       then
 106          Write_Info_Terminate;
 107       else
 108          --  Delete any trailing blanks
 109
 110          while Info_Buffer_Len > 0
 111            and then Info_Buffer (Info_Buffer_Len) = ' '
 112          loop
 113             Info_Buffer_Len := Info_Buffer_Len - 1;
 114          end loop;
 115
 116          Info_Buffer_Len := Info_Buffer_Len + 1;
 117          Info_Buffer (Info_Buffer_Len) := ASCII.LF;
 118          Info_Buffer_Col := 1;
 119       end if;
 120    end Write_Info_EOL;
 121
 122    -------------------------
 123    -- Write_Info_Hex_Byte --
 124    -------------------------
 125
 126    procedure Write_Info_Hex_Byte (J : Natural) is
 127       Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
 128    begin
 129       Write_Info_Char (Hexd (J / 16));
 130       Write_Info_Char (Hexd (J mod 16));
 131    end Write_Info_Hex_Byte;
 132
 133    -------------------------
 134    -- Write_Info_Initiate --
 135    -------------------------
 136
 137    procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
 138
 139    --------------------
 140    -- Write_Info_Int --
 141    --------------------
 142
 143    procedure Write_Info_Int (N : Int) is
 144    begin
 145       if N >= 0 then
 146          Write_Info_Nat (N);
 147
 148       --  Negative numbers, use Write_Info_Uint to avoid problems with largest
 149       --  negative number.
 150
 151       else
 152          Write_Info_Uint (UI_From_Int (N));
 153       end if;
 154    end Write_Info_Int;
 155
 156    ---------------------
 157    -- Write_Info_Name --
 158    ---------------------
 159
 160    procedure Write_Info_Name (Name : Name_Id) is
 161    begin
 162       Get_Name_String (Name);
 163       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 164         Name_Buffer (1 .. Name_Len);
 165       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 166       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 167    end Write_Info_Name;
 168
 169    procedure Write_Info_Name (Name : File_Name_Type) is
 170    begin
 171       Write_Info_Name (Name_Id (Name));
 172    end Write_Info_Name;
 173
 174    procedure Write_Info_Name (Name : Unit_Name_Type) is
 175    begin
 176       Write_Info_Name (Name_Id (Name));
 177    end Write_Info_Name;
 178
 179    --------------------
 180    -- Write_Info_Nat --
 181    --------------------
 182
 183    procedure Write_Info_Nat (N : Nat) is
 184    begin
 185       if N > 9 then
 186          Write_Info_Nat (N / 10);
 187       end if;
 188
 189       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
 190    end Write_Info_Nat;
 191
 192    ---------------------
 193    -- Write_Info_Slit --
 194    ---------------------
 195
 196    procedure Write_Info_Slit (S : String_Id) is
 197       C : Character;
 198
 199    begin
 200       Write_Info_Str ("""");
 201
 202       for J in 1 .. String_Length (S) loop
 203          C := Get_Character (Get_String_Char (S, J));
 204
 205          if C in Character'Val (16#20#) .. Character'Val (16#7E#)
 206            and then C /= '{'
 207          then
 208             Write_Info_Char (C);
 209
 210             if C = '"' then
 211                Write_Info_Char (C);
 212             end if;
 213
 214          else
 215             Write_Info_Char ('{');
 216             Write_Info_Hex_Byte (Character'Pos (C));
 217             Write_Info_Char ('}');
 218          end if;
 219       end loop;
 220
 221       Write_Info_Char ('"');
 222    end Write_Info_Slit;
 223
 224    --------------------
 225    -- Write_Info_Str --
 226    --------------------
 227
 228    procedure Write_Info_Str (Val : String) is
 229    begin
 230       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
 231                                                                   := Val;
 232       Info_Buffer_Len := Info_Buffer_Len + Val'Length;
 233       Info_Buffer_Col := Info_Buffer_Col + Val'Length;
 234    end Write_Info_Str;
 235
 236    --------------------
 237    -- Write_Info_Tab --
 238    --------------------
 239
 240    procedure Write_Info_Tab (Col : Positive) is
 241       Next_Tab : Positive;
 242
 243    begin
 244       if Col <= Info_Buffer_Col then
 245          Write_Info_Str ("  ");
 246       else
 247          loop
 248             Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
 249             exit when Col < Next_Tab;
 250             Write_Info_Char (ASCII.HT);
 251             Info_Buffer_Col := Next_Tab;
 252          end loop;
 253
 254          while Info_Buffer_Col < Col loop
 255             Write_Info_Char (' ');
 256          end loop;
 257       end if;
 258    end Write_Info_Tab;
 259
 260    --------------------------
 261    -- Write_Info_Terminate --
 262    --------------------------
 263
 264    procedure Write_Info_Terminate is
 265    begin
 266       --  Delete any trailing blanks
 267
 268       while Info_Buffer_Len > 0
 269         and then Info_Buffer (Info_Buffer_Len) = ' '
 270       loop
 271          Info_Buffer_Len := Info_Buffer_Len - 1;
 272       end loop;
 273
 274       --  Write_Library_Info adds the EOL
 275
 276       Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
 277
 278       Info_Buffer_Len := 0;
 279       Info_Buffer_Col := 1;
 280    end Write_Info_Terminate;
 281
 282    ---------------------
 283    -- Write_Info_Uint --
 284    ---------------------
 285
 286    procedure Write_Info_Uint (N : Uint) is
 287    begin
 288       UI_Image (N, Decimal);
 289       Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
 290    end Write_Info_Uint;
 291
 292 end Lib.Util;