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-2013, 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_Name_May_Be_Quoted --
 181    -----------------------------------
 182
 183    procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
 184       Quoted : Boolean := False;
 185       Cur    : Positive;
 186
 187    begin
 188       Get_Name_String (Name);
 189
 190       --  The file/path name is quoted only if it includes spaces
 191
 192       for J in 1 .. Name_Len loop
 193          if Name_Buffer (J) = ' ' then
 194             Quoted := True;
 195             exit;
 196          end if;
 197       end loop;
 198
 199       --  Deal with quoting string if needed
 200
 201       if Quoted then
 202          Insert_Str_In_Name_Buffer ("""", 1);
 203          Add_Char_To_Name_Buffer ('"');
 204
 205          --  Any character '"' is doubled
 206
 207          Cur := 2;
 208          while Cur < Name_Len loop
 209             if Name_Buffer (Cur) = '"' then
 210                Insert_Str_In_Name_Buffer ("""", Cur);
 211                Cur := Cur + 2;
 212             else
 213                Cur := Cur + 1;
 214             end if;
 215          end loop;
 216       end if;
 217
 218       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 219         Name_Buffer (1 .. Name_Len);
 220       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 221       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 222    end Write_Info_Name_May_Be_Quoted;
 223
 224    --------------------
 225    -- Write_Info_Nat --
 226    --------------------
 227
 228    procedure Write_Info_Nat (N : Nat) is
 229    begin
 230       if N > 9 then
 231          Write_Info_Nat (N / 10);
 232       end if;
 233
 234       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
 235    end Write_Info_Nat;
 236
 237    ---------------------
 238    -- Write_Info_Slit --
 239    ---------------------
 240
 241    procedure Write_Info_Slit (S : String_Id) is
 242       C : Character;
 243
 244    begin
 245       Write_Info_Str ("""");
 246
 247       for J in 1 .. String_Length (S) loop
 248          C := Get_Character (Get_String_Char (S, J));
 249
 250          if C in Character'Val (16#20#) .. Character'Val (16#7E#)
 251            and then C /= '{'
 252          then
 253             Write_Info_Char (C);
 254
 255             if C = '"' then
 256                Write_Info_Char (C);
 257             end if;
 258
 259          else
 260             Write_Info_Char ('{');
 261             Write_Info_Hex_Byte (Character'Pos (C));
 262             Write_Info_Char ('}');
 263          end if;
 264       end loop;
 265
 266       Write_Info_Char ('"');
 267    end Write_Info_Slit;
 268
 269    --------------------
 270    -- Write_Info_Str --
 271    --------------------
 272
 273    procedure Write_Info_Str (Val : String) is
 274    begin
 275       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
 276                                                                   := Val;
 277       Info_Buffer_Len := Info_Buffer_Len + Val'Length;
 278       Info_Buffer_Col := Info_Buffer_Col + Val'Length;
 279    end Write_Info_Str;
 280
 281    --------------------
 282    -- Write_Info_Tab --
 283    --------------------
 284
 285    procedure Write_Info_Tab (Col : Positive) is
 286       Next_Tab : Positive;
 287
 288    begin
 289       if Col <= Info_Buffer_Col then
 290          Write_Info_Str ("  ");
 291       else
 292          loop
 293             Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
 294             exit when Col < Next_Tab;
 295             Write_Info_Char (ASCII.HT);
 296             Info_Buffer_Col := Next_Tab;
 297          end loop;
 298
 299          while Info_Buffer_Col < Col loop
 300             Write_Info_Char (' ');
 301          end loop;
 302       end if;
 303    end Write_Info_Tab;
 304
 305    --------------------------
 306    -- Write_Info_Terminate --
 307    --------------------------
 308
 309    procedure Write_Info_Terminate is
 310    begin
 311       --  Delete any trailing blanks
 312
 313       while Info_Buffer_Len > 0
 314         and then Info_Buffer (Info_Buffer_Len) = ' '
 315       loop
 316          Info_Buffer_Len := Info_Buffer_Len - 1;
 317       end loop;
 318
 319       --  Write_Library_Info adds the EOL
 320
 321       Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
 322
 323       Info_Buffer_Len := 0;
 324       Info_Buffer_Col := 1;
 325    end Write_Info_Terminate;
 326
 327    ---------------------
 328    -- Write_Info_Uint --
 329    ---------------------
 330
 331    procedure Write_Info_Uint (N : Uint) is
 332    begin
 333       UI_Image (N, Decimal);
 334       Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
 335    end Write_Info_Uint;
 336
 337 end Lib.Util;