Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                                N A M E T                                 --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  WARNING: There is a C version of this package. Any changes to this

--  source file must be properly reflected in the C header file namet.h

--  which is created manually from namet.ads and namet.adb.

with Debug;    use Debug;

with Opt;      use Opt;

with Output;   use Output;

with Tree_IO;  use Tree_IO;

with Widechar; use Widechar;

with Interfaces; use Interfaces;

package body Namet is

   Name_Chars_Reserve   : constant := 5000;

   Name_Entries_Reserve : constant := 100;

   --  The names table is locked during gigi processing, since gigi assumes

   --  that the table does not move. After returning from gigi, the names

   --  table is unlocked again, since writing library file information needs

   --  to generate some extra names. To avoid the inefficiency of always

   --  reallocating during this second unlocked phase, we reserve a bit of

   --  extra space before doing the release call.

   Hash_Num : constant Int := 2**16;

   --  Number of headers in the hash table. Current hash algorithm is closely

   --  tailored to this choice, so it can only be changed if a corresponding

   --  change is made to the hash algorithm.

   Hash_Max : constant Int := Hash_Num - 1;

   --  Indexes in the hash header table run from 0 to Hash_Num - 1

   subtype Hash_Index_Type is Int range 0 .. Hash_Max;

   --  Range of hash index values

   Hash_Table : array (Hash_Index_Type) of Name_Id;

   --  The hash table is used to locate existing entries in the names table.

   --  The entries point to the first names table entry whose hash value

   --  matches the hash code. Then subsequent names table entries with the

   --  same hash code value are linked through the Hash_Link fields.

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Hash return Hash_Index_Type;

   pragma Inline (Hash);

   --  Compute hash code for name stored in Name_Buffer (length in Name_Len)

   procedure Strip_Qualification_And_Suffixes;

   --  Given an encoded entity name in Name_Buffer, remove package body

   --  suffix as described for Strip_Package_Body_Suffix, and also remove

   --  all qualification, i.e. names followed by two underscores. The

   --  contents of Name_Buffer is modified by this call, and on return

   --  Name_Buffer and Name_Len reflect the stripped name.

   -----------------------------

   -- Add_Char_To_Name_Buffer --

   -----------------------------

   procedure Add_Char_To_Name_Buffer (C : Character) is

   begin

      if Name_Len < Name_Buffer'Last then

         Name_Len := Name_Len + 1;

         Name_Buffer (Name_Len) := C;

      end if;

   end Add_Char_To_Name_Buffer;

   ----------------------------

   -- Add_Nat_To_Name_Buffer --

   ----------------------------

   procedure Add_Nat_To_Name_Buffer (V : Nat) is

   begin

      if V >= 10 then

         Add_Nat_To_Name_Buffer (V / 10);

      end if;

      Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));

   end Add_Nat_To_Name_Buffer;

   ----------------------------

   -- Add_Str_To_Name_Buffer --

   ----------------------------

   procedure Add_Str_To_Name_Buffer (S : String) is

   begin

      for J in S'Range loop

         Add_Char_To_Name_Buffer (S (J));

      end loop;

   end Add_Str_To_Name_Buffer;

   --------------

   -- Finalize --

   --------------

   procedure Finalize is

      F : array (Int range 0 .. 50) of Int;

      --  N'th entry is the number of chains of length N, except last entry,

      --  which is the number of chains of length F'Last or more.

      Max_Chain_Length : Int := 0;

      --  Maximum length of all chains

      Probes : Int := 0;

      --  Used to compute average number of probes

      Nsyms : Int := 0;

      --  Number of symbols in table

      Verbosity : constant Int range 1 .. 3 := 1;

      pragma Warnings (Off, Verbosity);

      --  This constant indicates the level of verbosity in the output from

      --  this procedure. Currently this can only be changed by editing the

      --  declaration above and recompiling. That's good enough in practice,

      --  since we very rarely need to use this debug option. Settings are:

      --

      --    1 => print basic summary information

      --    2 => in addition print number of entries per hash chain

      --    3 => in addition print content of entries

      Zero : constant Int := Character'Pos ('0');

   begin

      if not Debug_Flag_H then

         return;

      end if;

      for J in F'Range loop

         F (J) := 0;

      end loop;

      for J in Hash_Index_Type loop

         if Hash_Table (J) = No_Name then

            F (0) := F (0) + 1;

         else

            declare

               C : Int;

               N : Name_Id;

               S : Int;

            begin

               C := 0;

               N := Hash_Table (J);

               while N /= No_Name loop

                  N := Name_Entries.Table (N).Hash_Link;

                  C := C + 1;

               end loop;

               Nsyms := Nsyms + 1;

               Probes := Probes + (1 + C) * 100;

               if C > Max_Chain_Length then

                  Max_Chain_Length := C;

               end if;

               if Verbosity >= 2 then

                  Write_Str ("Hash_Table (");

                  Write_Int (J);

                  Write_Str (") has ");

                  Write_Int (C);

                  Write_Str (" entries");

                  Write_Eol;

               end if;

               if C < F'Last then

                  F (C) := F (C) + 1;

               else

                  F (F'Last) := F (F'Last) + 1;

               end if;

               if Verbosity >= 3 then

                  N := Hash_Table (J);

                  while N /= No_Name loop

                     S := Name_Entries.Table (N).Name_Chars_Index;

                     Write_Str ("      ");

                     for J in 1 .. Name_Entries.Table (N).Name_Len loop

                        Write_Char (Name_Chars.Table (S + Int (J)));

                     end loop;

                     Write_Eol;

                     N := Name_Entries.Table (N).Hash_Link;

                  end loop;

               end if;

            end;

         end if;

      end loop;

      Write_Eol;

      for J in F'Range loop

         if F (J) /= 0 then

            Write_Str ("Number of hash chains of length ");

            if J < 10 then

               Write_Char (' ');

            end if;

            Write_Int (J);

            if J = F'Last then

               Write_Str (" or greater");

            end if;

            Write_Str (" = ");

            Write_Int (F (J));

            Write_Eol;

         end if;

      end loop;

      --  Print out average number of probes, in the case where Name_Find is

      --  called for a string that is already in the table.

      Write_Eol;

      Write_Str ("Average number of probes for lookup = ");

      Probes := Probes / Nsyms;

      Write_Int (Probes / 200);

      Write_Char ('.');

      Probes := (Probes mod 200) / 2;

      Write_Char (Character'Val (Zero + Probes / 10));

      Write_Char (Character'Val (Zero + Probes mod 10));

      Write_Eol;

      Write_Str ("Max_Chain_Length = ");

      Write_Int (Max_Chain_Length);

      Write_Eol;

      Write_Str ("Name_Chars'Length = ");

      Write_Int (Name_Chars.Last - Name_Chars.First + 1);

      Write_Eol;

      Write_Str ("Name_Entries'Length = ");

      Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));

      Write_Eol;

      Write_Str ("Nsyms = ");

      Write_Int (Nsyms);

      Write_Eol;

   end Finalize;

   -----------------------------

   -- Get_Decoded_Name_String --

   -----------------------------

   procedure Get_Decoded_Name_String (Id : Name_Id) is

      C : Character;

      P : Natural;

   begin

      Get_Name_String (Id);

      --  Skip scan if we already know there are no encodings

      if Name_Entries.Table (Id).Name_Has_No_Encodings then

         return;

      end if;

      --  Quick loop to see if there is anything special to do

      P := 1;

      loop

         if P = Name_Len then

            Name_Entries.Table (Id).Name_Has_No_Encodings := True;

            return;

         else

            C := Name_Buffer (P);

            exit when

              C = 'U' or else

              C = 'W' or else

              C = 'Q' or else

              C = 'O';

            P := P + 1;

         end if;

      end loop;

      --  Here we have at least some encoding that we must decode

      Decode : declare

         New_Len : Natural;

         Old     : Positive;

         New_Buf : String (1 .. Name_Buffer'Last);

         procedure Copy_One_Character;

         --  Copy a character from Name_Buffer to New_Buf. Includes case

         --  of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.

         function Hex (N : Natural) return Word;

         --  Scans past N digits using Old pointer and returns hex value

         procedure Insert_Character (C : Character);

         --  Insert a new character into output decoded name

         ------------------------

         -- Copy_One_Character --

         ------------------------

         procedure Copy_One_Character is

            C : Character;

         begin

            C := Name_Buffer (Old);

            --  U (upper half insertion case)

            if C = 'U'

              and then Old < Name_Len

              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'

              and then Name_Buffer (Old + 1) /= '_'

            then

               Old := Old + 1;

               --  If we have upper half encoding, then we have to set an

               --  appropriate wide character sequence for this character.

               if Upper_Half_Encoding then

                  Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);

                  --  For other encoding methods, upper half characters can

                  --  simply use their normal representation.

               else

                  Insert_Character (Character'Val (Hex (2)));

               end if;

            --  WW (wide wide character insertion)

            elsif C = 'W'

              and then Old < Name_Len

              and then Name_Buffer (Old + 1) = 'W'

            then

               Old := Old + 2;

               Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);

            --  W (wide character insertion)

            elsif C = 'W'

              and then Old < Name_Len

              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'

              and then Name_Buffer (Old + 1) /= '_'

            then

               Old := Old + 1;

               Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);

            --  Any other character is copied unchanged

            else

               Insert_Character (C);

               Old := Old + 1;

            end if;

         end Copy_One_Character;

         ---------

         -- Hex --

         ---------

         function Hex (N : Natural) return Word is

            T : Word := 0;

            C : Character;

         begin

            for J in 1 .. N loop

               C := Name_Buffer (Old);

               Old := Old + 1;

               pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');

               if C <= '9' then

                  T := 16 * T + Character'Pos (C) - Character'Pos ('0');

               else -- C in 'a' .. 'f'

                  T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);

               end if;

            end loop;

            return T;

         end Hex;

         ----------------------

         -- Insert_Character --

         ----------------------

         procedure Insert_Character (C : Character) is

         begin

            New_Len := New_Len + 1;

            New_Buf (New_Len) := C;

         end Insert_Character;

      --  Start of processing for Decode

      begin

         New_Len := 0;

         Old := 1;

         --  Loop through characters of name

         while Old <= Name_Len loop

            --  Case of character literal, put apostrophes around character

            if Name_Buffer (Old) = 'Q'

              and then Old < Name_Len

            then

               Old := Old + 1;

               Insert_Character (''');

               Copy_One_Character;

               Insert_Character (''');

            --  Case of operator name

            elsif Name_Buffer (Old) = 'O'

              and then Old < Name_Len

              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'

              and then Name_Buffer (Old + 1) /= '_'

            then

               Old := Old + 1;

               declare

                  --  This table maps the 2nd and 3rd characters of the name

                  --  into the required output. Two blanks means leave the

                  --  name alone

                  Map : constant String :=

                     "ab  " &               --  Oabs         => "abs"

                     "ad+ " &               --  Oadd         => "+"

                     "an  " &               --  Oand         => "and"

                     "co& " &               --  Oconcat      => "&"

                     "di/ " &               --  Odivide      => "/"

                     "eq= " &               --  Oeq          => "="

                     "ex**" &               --  Oexpon       => "**"

                     "gt> " &               --  Ogt          => ">"

                     "ge>=" &               --  Oge          => ">="

                     "le<=" &               --  Ole          => "<="

                     "lt< " &               --  Olt          => "<"

                     "mo  " &               --  Omod         => "mod"

                     "mu* " &               --  Omutliply    => "*"

                     "ne/=" &               --  One          => "/="

                     "no  " &               --  Onot         => "not"

                     "or  " &               --  Oor          => "or"

                     "re  " &               --  Orem         => "rem"

                     "su- " &               --  Osubtract    => "-"

                     "xo  ";                --  Oxor         => "xor"

                  J : Integer;

               begin

                  Insert_Character ('"');

                  --  Search the map. Note that this loop must terminate, if

                  --  not we have some kind of internal error, and a constraint

                  --  error may be raised.

                  J := Map'First;

                  loop

                     exit when Name_Buffer (Old) = Map (J)

                       and then Name_Buffer (Old + 1) = Map (J + 1);

                     J := J + 4;

                  end loop;

                  --  Special operator name

                  if Map (J + 2) /= ' ' then

                     Insert_Character (Map (J + 2));

                     if Map (J + 3) /= ' ' then

                        Insert_Character (Map (J + 3));

                     end if;

                     Insert_Character ('"');

                     --  Skip past original operator name in input

                     while Old <= Name_Len

                       and then Name_Buffer (Old) in 'a' .. 'z'

                     loop

                        Old := Old + 1;

                     end loop;

                  --  For other operator names, leave them in lower case,

                  --  surrounded by apostrophes

                  else

                     --  Copy original operator name from input to output

                     while Old <= Name_Len

                        and then Name_Buffer (Old) in 'a' .. 'z'

                     loop

                        Copy_One_Character;

                     end loop;

                     Insert_Character ('"');

                  end if;

               end;

            --  Else copy one character and keep going

            else

               Copy_One_Character;

            end if;

         end loop;

         --  Copy new buffer as result

         Name_Len := New_Len;

         Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);

      end Decode;

   end Get_Decoded_Name_String;

   -------------------------------------------

   -- Get_Decoded_Name_String_With_Brackets --

   -------------------------------------------

   procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is

      P : Natural;

   begin

      --  Case of operator name, normal decoding is fine

      if Name_Buffer (1) = 'O' then

         Get_Decoded_Name_String (Id);

      --  For character literals, normal decoding is fine

      elsif Name_Buffer (1) = 'Q' then

         Get_Decoded_Name_String (Id);

      --  Only remaining issue is U/W/WW sequences

      else

         Get_Name_String (Id);

         P := 1;

         while P < Name_Len loop

            if Name_Buffer (P + 1) in 'A' .. 'Z' then

               P := P + 1;

            --  Uhh encoding

            elsif Name_Buffer (P) = 'U' then

               for J in reverse P + 3 .. P + Name_Len loop

                  Name_Buffer (J + 3) := Name_Buffer (J);

               end loop;

               Name_Len := Name_Len + 3;

               Name_Buffer (P + 3) := Name_Buffer (P + 2);

               Name_Buffer (P + 2) := Name_Buffer (P + 1);

               Name_Buffer (P)     := '[';

               Name_Buffer (P + 1) := '"';

               Name_Buffer (P + 4) := '"';

               Name_Buffer (P + 5) := ']';

               P := P + 6;

            --  WWhhhhhhhh encoding

            elsif Name_Buffer (P) = 'W'

              and then P + 9 <= Name_Len

              and then Name_Buffer (P + 1) = 'W'

              and then Name_Buffer (P + 2) not in 'A' .. 'Z'

              and then Name_Buffer (P + 2) /= '_'

            then

               Name_Buffer (P + 12 .. Name_Len + 2) :=

                 Name_Buffer (P + 10 .. Name_Len);

               Name_Buffer (P)     := '[';

               Name_Buffer (P + 1) := '"';

               Name_Buffer (P + 10) := '"';

               Name_Buffer (P + 11) := ']';

               Name_Len := Name_Len + 2;

               P := P + 12;

            --  Whhhh encoding

            elsif Name_Buffer (P) = 'W'

              and then P < Name_Len

              and then Name_Buffer (P + 1) not in 'A' .. 'Z'

              and then Name_Buffer (P + 1) /= '_'

            then

               Name_Buffer (P + 8 .. P + Name_Len + 3) :=

                 Name_Buffer (P + 5 .. Name_Len);

               Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);

               Name_Buffer (P)     := '[';

               Name_Buffer (P + 1) := '"';

               Name_Buffer (P + 6) := '"';

               Name_Buffer (P + 7) := ']';

               Name_Len := Name_Len + 3;

               P := P + 8;

            else

               P := P + 1;

            end if;

         end loop;

      end if;

   end Get_Decoded_Name_String_With_Brackets;

   ------------------------

   -- Get_Last_Two_Chars --

   ------------------------

   procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is

      NE  : Name_Entry renames Name_Entries.Table (N);

      NEL : constant Int := Int (NE.Name_Len);

   begin

      if NEL >= 2 then

         C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);

         C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);

      else

         C1 := ASCII.NUL;

         C2 := ASCII.NUL;

      end if;

   end Get_Last_Two_Chars;

   ---------------------

   -- Get_Name_String --

   ---------------------

   --  Procedure version leaving result in Name_Buffer, length in Name_Len

   procedure Get_Name_String (Id : Name_Id) is

      S : Int;

   begin

      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      S := Name_Entries.Table (Id).Name_Chars_Index;

      Name_Len := Natural (Name_Entries.Table (Id).Name_Len);

      for J in 1 .. Name_Len loop

         Name_Buffer (J) := Name_Chars.Table (S + Int (J));

      end loop;

   end Get_Name_String;

   ---------------------

   -- Get_Name_String --

   ---------------------

   --  Function version returning a string

   function Get_Name_String (Id : Name_Id) return String is

      S : Int;

   begin

      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      S := Name_Entries.Table (Id).Name_Chars_Index;

      declare

         R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));

      begin

         for J in R'Range loop

            R (J) := Name_Chars.Table (S + Int (J));

         end loop;

         return R;

      end;

   end Get_Name_String;

   --------------------------------

   -- Get_Name_String_And_Append --

   --------------------------------

   procedure Get_Name_String_And_Append (Id : Name_Id) is

      S : Int;

   begin

      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      S := Name_Entries.Table (Id).Name_Chars_Index;

      for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop

         Name_Len := Name_Len + 1;

         Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));

      end loop;

   end Get_Name_String_And_Append;

   -------------------------

   -- Get_Name_Table_Byte --

   -------------------------

   function Get_Name_Table_Byte (Id : Name_Id) return Byte is

   begin

      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      return Name_Entries.Table (Id).Byte_Info;

   end Get_Name_Table_Byte;

   -------------------------

   -- Get_Name_Table_Info --

   -------------------------

   function Get_Name_Table_Info (Id : Name_Id) return Int is

   begin

      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      return Name_Entries.Table (Id).Int_Info;

   end Get_Name_Table_Info;

   -----------------------------------------

   -- Get_Unqualified_Decoded_Name_String --

   -----------------------------------------

   procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is

   begin

      Get_Decoded_Name_String (Id);

      Strip_Qualification_And_Suffixes;

   end Get_Unqualified_Decoded_Name_String;

   ---------------------------------

   -- Get_Unqualified_Name_String --

   ---------------------------------

   procedure Get_Unqualified_Name_String (Id : Name_Id) is

   begin

      Get_Name_String (Id);

      Strip_Qualification_And_Suffixes;

   end Get_Unqualified_Name_String;

   ----------

   -- Hash --

   ----------

   function Hash return Hash_Index_Type is

      --  This hash function looks at every character, in order to make it

      --  likely that similar strings get different hash values. The rotate by

      --  7 bits has been determined empirically to be good, and it doesn't

      --  lose bits like a shift would. The final conversion can't overflow,

      --  because the table is 2**16 in size. This function probably needs to

      --  be changed if the hash table size is changed.

      --  Note that we could get some speed improvement by aligning the string

      --  to 32 or 64 bits, and doing word-wise xor's. We could also implement

      --  a growable table. It doesn't seem worth the trouble to do those

      --  things, for now.

      Result : Unsigned_16 := 0;

   begin

      for J in 1 .. Name_Len loop

         Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J));

      end loop;

      return Hash_Index_Type (Result);

   end Hash;

   ----------------

   -- Initialize --

   ----------------

   procedure Initialize is

   begin

      null;

   end Initialize;

   -------------------------------

   -- Insert_Str_In_Name_Buffer --

   -------------------------------

   procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is

      SL : constant Natural := S'Length;

   begin

      Name_Buffer (Index + SL .. Name_Len + SL) :=

        Name_Buffer (Index .. Name_Len);

      Name_Buffer (Index .. Index + SL - 1) := S;

      Name_Len := Name_Len + SL;

   end Insert_Str_In_Name_Buffer;

   ----------------------

   -- Is_Internal_Name --

   ----------------------

   --  Version taking an argument

   function Is_Internal_Name (Id : Name_Id) return Boolean is

   begin

      Get_Name_String (Id);

      return Is_Internal_Name;

   end Is_Internal_Name;

   ----------------------

   -- Is_Internal_Name --

   ----------------------

   --  Version taking its input from Name_Buffer

   function Is_Internal_Name return Boolean is

   begin

      if Name_Buffer (1) = '_'

        or else Name_Buffer (Name_Len) = '_'

      then

         return True;

      else

         --  Test backwards, because we only want to test the last entity

         --  name if the name we have is qualified with other entities.

         for J in reverse 1 .. Name_Len loop