gcc/ada/aa_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                        GNAAMP COMPILER COMPONENTS                        --
   4 --                                                                          --
   5 --                              A A _ U T I L                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2001-2012, AdaCore                     --
  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 ------------------------------------------------------------------------------
  22
  23 with Sem_Aux; use Sem_Aux;
  24 with Sinput;  use Sinput;
  25 with Stand;   use Stand;
  26 with Stringt; use Stringt;
  27
  28 with GNAT.Case_Util;  use GNAT.Case_Util;
  29
  30 package body AA_Util is
  31
  32    ----------------------
  33    -- Is_Global_Entity --
  34    ----------------------
  35
  36    function Is_Global_Entity (E : Entity_Id) return Boolean is
  37    begin
  38       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
  39    end Is_Global_Entity;
  40
  41    -----------------
  42    -- New_Name_Id --
  43    -----------------
  44
  45    function New_Name_Id (Name : String) return Name_Id is
  46    begin
  47       for J in 1 .. Name'Length loop
  48          Name_Buffer (J) := Name (Name'First + (J - 1));
  49       end loop;
  50
  51       Name_Len := Name'Length;
  52       return Name_Find;
  53    end New_Name_Id;
  54
  55    -----------------
  56    -- Name_String --
  57    -----------------
  58
  59    function Name_String (Name : Name_Id) return String is
  60    begin
  61       pragma Assert (Name /= No_Name);
  62       return Get_Name_String (Name);
  63    end Name_String;
  64
  65    -------------------
  66    -- New_String_Id --
  67    -------------------
  68
  69    function New_String_Id (S : String) return String_Id is
  70    begin
  71       for J in 1 .. S'Length loop
  72          Name_Buffer (J) := S (S'First + (J - 1));
  73       end loop;
  74
  75       Name_Len := S'Length;
  76       return String_From_Name_Buffer;
  77    end New_String_Id;
  78
  79    ------------------
  80    -- String_Value --
  81    ------------------
  82
  83    function String_Value (Str_Id : String_Id) return String is
  84    begin
  85       --  ??? pragma Assert (Str_Id /= No_String);
  86
  87       if Str_Id = No_String then
  88          return "";
  89       end if;
  90
  91       String_To_Name_Buffer (Str_Id);
  92
  93       return Name_Buffer (1 .. Name_Len);
  94    end String_Value;
  95
  96    ---------------
  97    -- Next_Name --
  98    ---------------
  99
 100    function Next_Name
 101      (Name_Seq    : not null access Name_Sequencer;
 102       Name_Prefix : String) return Name_Id
 103    is
 104    begin
 105       Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1;
 106
 107       declare
 108          Number_Image : constant String := Name_Seq.Sequence_Number'Img;
 109       begin
 110          return New_Name_Id
 111                   (Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last));
 112       end;
 113    end Next_Name;
 114
 115    --------------------
 116    -- Elab_Spec_Name --
 117    --------------------
 118
 119    function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is
 120    begin
 121       return New_Name_Id (Name_String (Module_Name) & "___elabs");
 122    end Elab_Spec_Name;
 123
 124    --------------------
 125    -- Elab_Spec_Name --
 126    --------------------
 127
 128    function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is
 129    begin
 130       return New_Name_Id (Name_String (Module_Name) & "___elabb");
 131    end Elab_Body_Name;
 132
 133    --------------------------------
 134    -- Source_Name_Without_Suffix --
 135    --------------------------------
 136
 137    function File_Name_Without_Suffix (File_Name : String) return String is
 138       Name_Index : Natural := File_Name'Last;
 139
 140    begin
 141       pragma Assert (File_Name'Length > 0);
 142
 143       --  We loop in reverse to ensure that file names that follow nonstandard
 144       --  naming conventions that include additional dots are handled properly,
 145       --  preserving dots in front of the main file suffix (for example,
 146       --  main.2.ada => main.2).
 147
 148       while Name_Index >= File_Name'First
 149         and then File_Name (Name_Index) /= '.'
 150       loop
 151          Name_Index := Name_Index - 1;
 152       end loop;
 153
 154       --  Return the part of the file name up to but not including the last dot
 155       --  in the name, or return the whole name as is if no dot character was
 156       --  found.
 157
 158       if Name_Index >= File_Name'First then
 159          return File_Name (File_Name'First .. Name_Index - 1);
 160
 161       else
 162          return File_Name;
 163       end if;
 164    end File_Name_Without_Suffix;
 165
 166    -----------------
 167    -- Source_Name --
 168    -----------------
 169
 170    function Source_Name (Sloc : Source_Ptr) return File_Name_Type is
 171    begin
 172       if Sloc = No_Location or Sloc = Standard_Location then
 173          return No_File;
 174       else
 175          return File_Name (Get_Source_File_Index (Sloc));
 176       end if;
 177    end Source_Name;
 178
 179    --------------------------------
 180    -- Source_Name_Without_Suffix --
 181    --------------------------------
 182
 183    function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is
 184       Src_Name  : constant String :=
 185         Name_String (Name_Id (Source_Name (Sloc)));
 186       Src_Index : Natural         := Src_Name'Last;
 187
 188    begin
 189       pragma Assert (Src_Name'Length > 0);
 190
 191       --  Treat the presence of a ".dg" suffix specially, stripping it off
 192       --  in addition to any suffix preceding it.
 193
 194       if Src_Name'Length >= 4
 195         and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg"
 196       then
 197          Src_Index := Src_Index - 3;
 198       end if;
 199
 200       return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index));
 201    end Source_Name_Without_Suffix;
 202
 203    ----------------------
 204    -- Source_Id_String --
 205    ----------------------
 206
 207    function Source_Id_String (Unit_Name : Name_Id) return String is
 208       Unit_String : String   := Name_String (Unit_Name);
 209       Name_Last   : Positive := Unit_String'Last;
 210       Name_Index  : Positive := Unit_String'First;
 211
 212    begin
 213       To_Mixed (Unit_String);
 214
 215       --  Replace any embedded sequences of two or more '_' characters
 216       --  with a single '.' character. Note that this will leave any
 217       --  leading or trailing single '_' characters untouched, but those
 218       --  should normally not occur in compilation unit names (and if
 219       --  they do then it's better to leave them as is).
 220
 221       while Name_Index <= Name_Last loop
 222          if Unit_String (Name_Index) = '_'
 223            and then Name_Index /= Name_Last
 224            and then Unit_String (Name_Index + 1) = '_'
 225          then
 226             Unit_String (Name_Index) := '.';
 227             Name_Index := Name_Index + 1;
 228
 229             while Unit_String (Name_Index) = '_'
 230               and then Name_Index <= Name_Last
 231             loop
 232                Unit_String (Name_Index .. Name_Last - 1)
 233                  := Unit_String (Name_Index + 1 .. Name_Last);
 234                Name_Last := Name_Last - 1;
 235             end loop;
 236
 237          else
 238             Name_Index := Name_Index + 1;
 239          end if;
 240       end loop;
 241
 242       return Unit_String (Unit_String'First .. Name_Last);
 243    end Source_Id_String;
 244
 245    --  This version of Source_Id_String is obsolescent and is being
 246    --  replaced with the above function.
 247
 248    function Source_Id_String (Sloc : Source_Ptr) return String is
 249       File_Index : Source_File_Index;
 250
 251    begin
 252       --  Use an arbitrary artificial 22-character value for package Standard,
 253       --  since Standard doesn't have an associated source file.
 254
 255       if Sloc <= Standard_Location then
 256          return "20010101010101standard";
 257
 258       --  Return the concatentation of the source file's timestamp and
 259       --  its 8-digit hex checksum.
 260
 261       else
 262          File_Index := Get_Source_File_Index (Sloc);
 263
 264          return String (Time_Stamp (File_Index))
 265                   & Get_Hex_String (Source_Checksum (File_Index));
 266       end if;
 267    end Source_Id_String;
 268
 269    ---------------
 270    -- Source_Id --
 271    ---------------
 272
 273    function Source_Id (Unit_Name : Name_Id) return String_Id is
 274    begin
 275       return New_String_Id (Source_Id_String (Unit_Name));
 276    end Source_Id;
 277
 278    --  This version of Source_Id is obsolescent and is being
 279    --  replaced with the above function.
 280
 281    function Source_Id (Sloc : Source_Ptr) return String_Id is
 282    begin
 283       return New_String_Id (Source_Id_String (Sloc));
 284    end Source_Id;
 285
 286    -----------
 287    -- Image --
 288    -----------
 289
 290    function Image (I : Int) return String is
 291       Image_String : constant String := Pos'Image (I);
 292    begin
 293       if Image_String (1) = ' ' then
 294          return Image_String (2 .. Image_String'Last);
 295       else
 296          return Image_String;
 297       end if;
 298    end Image;
 299
 300    --------------
 301    -- UI_Image --
 302    --------------
 303
 304    function UI_Image (I : Uint; Format : Integer_Image_Format) return String is
 305    begin
 306       if Format = Decimal then
 307          UI_Image (I, Format => Decimal);
 308          return UI_Image_Buffer (1 .. UI_Image_Length);
 309
 310       elsif Format = Ada_Hex then
 311          UI_Image (I, Format => Hex);
 312          return UI_Image_Buffer (1 .. UI_Image_Length);
 313
 314       else
 315          pragma Assert (I >= Uint_0);
 316
 317          UI_Image (I, Format => Hex);
 318
 319          pragma Assert (UI_Image_Buffer (1 .. 3) = "16#"
 320                          and then UI_Image_Buffer (UI_Image_Length) = '#');
 321
 322          --  Declare a string where we will copy the digits from the UI_Image,
 323          --  interspersing '_' characters as 4-digit group separators. The
 324          --  underscores in UI_Image's result are not always at the places
 325          --  where we want them, which is why we do the following copy
 326          --  (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^").
 327
 328          declare
 329             Hex_String     : String (1 .. UI_Image_Max);
 330             Last_Index     : Natural;
 331             Digit_Count    : Natural := 0;
 332             UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket
 333             Sep_Count      : Natural := 0;
 334
 335          begin
 336             --  Count up the number of non-underscore characters in the
 337             --  literal value portion of the UI_Image string.
 338
 339             while UI_Image_Buffer (UI_Image_Index) /= '#' loop
 340                if UI_Image_Buffer (UI_Image_Index) /= '_' then
 341                   Digit_Count := Digit_Count + 1;
 342                end if;
 343
 344                UI_Image_Index := UI_Image_Index + 1;
 345             end loop;
 346
 347             UI_Image_Index := 4; -- Reset the index past the "16#" bracket
 348
 349             Last_Index := 1;
 350
 351             Hex_String (Last_Index) := '^';
 352             Last_Index := Last_Index + 1;
 353
 354             --  Copy digits from UI_Image_Buffer to Hex_String, adding
 355             --  underscore separators as appropriate. The initial value
 356             --  of Sep_Count accounts for the leading '^' and being one
 357             --  character ahead after inserting a digit.
 358
 359             Sep_Count := 2;
 360
 361             while UI_Image_Buffer (UI_Image_Index) /= '#' loop
 362                if UI_Image_Buffer (UI_Image_Index) /= '_' then
 363                   Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index);
 364
 365                   Last_Index := Last_Index + 1;
 366
 367                   --  Add '_' characters to separate groups of four hex
 368                   --  digits for readability (grouping from right to left).
 369
 370                   if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then
 371                      Hex_String (Last_Index) := '_';
 372                      Last_Index := Last_Index + 1;
 373                      Sep_Count := Sep_Count + 1;
 374                   end if;
 375                end if;
 376
 377                UI_Image_Index := UI_Image_Index + 1;
 378             end loop;
 379
 380             --  Back up before any trailing underscore
 381
 382             if Hex_String (Last_Index - 1) = '_' then
 383                Last_Index := Last_Index - 1;
 384             end if;
 385
 386             Hex_String (Last_Index) := '^';
 387
 388             return Hex_String (1 .. Last_Index);
 389          end;
 390       end if;
 391    end UI_Image;
 392
 393    --------------
 394    -- UR_Image --
 395    --------------
 396
 397    --  Shouldn't this be added to Urealp???
 398
 399    function UR_Image (R : Ureal) return String is
 400
 401       --  The algorithm used here for conversion of Ureal values
 402       --  is taken from the JGNAT back end.
 403
 404       Num    : Long_Long_Float := 0.0;
 405       Den    : Long_Long_Float := 0.0;
 406       Sign   : Long_Long_Float := 1.0;
 407       Result : Long_Long_Float;
 408       Tmp    : Uint;
 409       Index  : Integer;
 410
 411    begin
 412       if UR_Is_Negative (R) then
 413          Sign := -1.0;
 414       end if;
 415
 416       --  In the following calculus, we consider numbers modulo 2 ** 31,
 417       --  so that we don't have problems with signed Int...
 418
 419       Tmp := abs (Numerator (R));
 420       Index := 0;
 421       while Tmp > 0 loop
 422          Num := Num
 423            + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
 424            * (2.0 ** Index);
 425          Tmp := Tmp / Uint_2 ** 31;
 426          Index := Index + 31;
 427       end loop;
 428
 429       Tmp := abs (Denominator (R));
 430       if Rbase (R) /= 0 then
 431          Tmp := Rbase (R) ** Tmp;
 432       end if;
 433
 434       Index := 0;
 435       while Tmp > 0 loop
 436          Den := Den
 437            + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
 438            * (2.0 ** Index);
 439          Tmp := Tmp / Uint_2 ** 31;
 440          Index := Index + 31;
 441       end loop;
 442
 443       --  If the denominator denotes a negative power of Rbase,
 444       --  then multiply by the denominator.
 445
 446       if Rbase (R) /= 0 and then Denominator (R) < 0 then
 447          Result := Sign * Num * Den;
 448
 449       --  Otherwise compute the quotient
 450
 451       else
 452          Result := Sign * Num / Den;
 453       end if;
 454
 455       return Long_Long_Float'Image (Result);
 456    end UR_Image;
 457
 458 end AA_Util;