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-2023, 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 Info_Buffer_Len + Max_Line + 1 > Max_Buffer then
 104          Write_Info_Terminate;
 105
 106       else
 107          --  Delete any trailing blanks
 108
 109          while Info_Buffer_Len > 0
 110            and then Info_Buffer (Info_Buffer_Len) = ' '
 111          loop
 112             Info_Buffer_Len := Info_Buffer_Len - 1;
 113          end loop;
 114
 115          Info_Buffer_Len := Info_Buffer_Len + 1;
 116          Info_Buffer (Info_Buffer_Len) := ASCII.LF;
 117          Info_Buffer_Col := 1;
 118       end if;
 119    end Write_Info_EOL;
 120
 121    -------------------------
 122    -- Write_Info_Hex_Byte --
 123    -------------------------
 124
 125    procedure Write_Info_Hex_Byte (J : Natural) is
 126       Hexd : constant array (0 .. 15) of Character := "0123456789abcdef";
 127    begin
 128       Write_Info_Char (Hexd (J / 16));
 129       Write_Info_Char (Hexd (J mod 16));
 130    end Write_Info_Hex_Byte;
 131
 132    -------------------------
 133    -- Write_Info_Initiate --
 134    -------------------------
 135
 136    procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
 137
 138    --------------------
 139    -- Write_Info_Int --
 140    --------------------
 141
 142    procedure Write_Info_Int (N : Int) is
 143    begin
 144       if N >= 0 then
 145          Write_Info_Nat (N);
 146
 147       --  Negative numbers, use Write_Info_Uint to avoid problems with largest
 148       --  negative number.
 149
 150       else
 151          Write_Info_Uint (UI_From_Int (N));
 152       end if;
 153    end Write_Info_Int;
 154
 155    ---------------------
 156    -- Write_Info_Name --
 157    ---------------------
 158
 159    procedure Write_Info_Name (Name : Name_Id) is
 160    begin
 161       Get_Name_String (Name);
 162       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 163         Name_Buffer (1 .. Name_Len);
 164       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 165       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 166    end Write_Info_Name;
 167
 168    procedure Write_Info_Name (Name : File_Name_Type) is
 169    begin
 170       Write_Info_Name (Name_Id (Name));
 171    end Write_Info_Name;
 172
 173    procedure Write_Info_Name (Name : Unit_Name_Type) is
 174    begin
 175       Write_Info_Name (Name_Id (Name));
 176    end Write_Info_Name;
 177
 178    -----------------------------------
 179    -- Write_Info_Name_May_Be_Quoted --
 180    -----------------------------------
 181
 182    procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
 183       Quoted : Boolean := False;
 184       Cur    : Positive;
 185
 186    begin
 187       Get_Name_String (Name);
 188
 189       --  The file/path name is quoted only if it includes spaces
 190
 191       for J in 1 .. Name_Len loop
 192          if Name_Buffer (J) = ' ' then
 193             Quoted := True;
 194             exit;
 195          end if;
 196       end loop;
 197
 198       --  Deal with quoting string if needed
 199
 200       if Quoted then
 201          Insert_Str_In_Name_Buffer ("""", 1);
 202          Add_Char_To_Name_Buffer ('"');
 203
 204          --  Any character '"' is doubled
 205
 206          Cur := 2;
 207          while Cur < Name_Len loop
 208             if Name_Buffer (Cur) = '"' then
 209                Insert_Str_In_Name_Buffer ("""", Cur);
 210                Cur := Cur + 2;
 211             else
 212                Cur := Cur + 1;
 213             end if;
 214          end loop;
 215       end if;
 216
 217       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
 218         Name_Buffer (1 .. Name_Len);
 219       Info_Buffer_Len := Info_Buffer_Len + Name_Len;
 220       Info_Buffer_Col := Info_Buffer_Col + Name_Len;
 221    end Write_Info_Name_May_Be_Quoted;
 222
 223    --------------------
 224    -- Write_Info_Nat --
 225    --------------------
 226
 227    procedure Write_Info_Nat (N : Nat) is
 228    begin
 229       if N > 9 then
 230          Write_Info_Nat (N / 10);
 231       end if;
 232
 233       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
 234    end Write_Info_Nat;
 235
 236    ---------------------
 237    -- Write_Info_Slit --
 238    ---------------------
 239
 240    procedure Write_Info_Slit (S : String_Id) is
 241       C : Character;
 242
 243    begin
 244       Write_Info_Str ("""");
 245
 246       for J in 1 .. String_Length (S) loop
 247          C := Get_Character (Get_String_Char (S, J));
 248
 249          if C in Character'Val (16#20#) .. Character'Val (16#7E#)
 250            and then C /= '{'
 251          then
 252             Write_Info_Char (C);
 253
 254             if C = '"' then
 255                Write_Info_Char (C);
 256             end if;
 257
 258          else
 259             Write_Info_Char ('{');
 260             Write_Info_Hex_Byte (Character'Pos (C));
 261             Write_Info_Char ('}');
 262          end if;
 263       end loop;
 264
 265       Write_Info_Char ('"');
 266    end Write_Info_Slit;
 267
 268    --------------------
 269    -- Write_Info_Str --
 270    --------------------
 271
 272    procedure Write_Info_Str (Val : String) is
 273    begin
 274       Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length)
 275                                                                   := Val;
 276       Info_Buffer_Len := Info_Buffer_Len + Val'Length;
 277       Info_Buffer_Col := Info_Buffer_Col + Val'Length;
 278    end Write_Info_Str;
 279
 280    --------------------
 281    -- Write_Info_Tab --
 282    --------------------
 283
 284    procedure Write_Info_Tab (Col : Positive) is
 285       Next_Tab : Positive;
 286
 287    begin
 288       if Col <= Info_Buffer_Col then
 289          Write_Info_Str ("  ");
 290       else
 291          loop
 292             Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1;
 293             exit when Col < Next_Tab;
 294             Write_Info_Char (ASCII.HT);
 295             Info_Buffer_Col := Next_Tab;
 296          end loop;
 297
 298          while Info_Buffer_Col < Col loop
 299             Write_Info_Char (' ');
 300          end loop;
 301       end if;
 302    end Write_Info_Tab;
 303
 304    --------------------------
 305    -- Write_Info_Terminate --
 306    --------------------------
 307
 308    procedure Write_Info_Terminate is
 309    begin
 310       --  Delete any trailing blanks
 311
 312       while Info_Buffer_Len > 0
 313         and then Info_Buffer (Info_Buffer_Len) = ' '
 314       loop
 315          Info_Buffer_Len := Info_Buffer_Len - 1;
 316       end loop;
 317
 318       --  Write_Library_Info adds the EOL
 319
 320       Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len));
 321
 322       Info_Buffer_Len := 0;
 323       Info_Buffer_Col := 1;
 324    end Write_Info_Terminate;
 325
 326    ---------------------
 327    -- Write_Info_Uint --
 328    ---------------------
 329
 330    procedure Write_Info_Uint (N : Uint) is
 331    begin
 332       UI_Image (N, Decimal);
 333       Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
 334    end Write_Info_Uint;
 335
 336 end Lib.Util;