URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [namet.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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
            if Is_OK_Internal_Letter (Name_Buffer (J)) then
               return True;
 
            --  Quit if we come to terminating double underscore (note that
            --  if the current character is an underscore, we know that
            --  there is a previous character present, since we already
            --  filtered out the case of Name_Buffer (1) = '_' above.
 
            elsif Name_Buffer (J) = '_'
              and then Name_Buffer (J - 1) = '_'
              and then Name_Buffer (J - 2) /= '_'
            then
               return False;
            end if;
         end loop;
      end if;
 
      return False;
   end Is_Internal_Name;
 
   ---------------------------
   -- Is_OK_Internal_Letter --
   ---------------------------
 
   function Is_OK_Internal_Letter (C : Character) return Boolean is
   begin
      return C in 'A' .. 'Z'
        and then C /= 'O'
        and then C /= 'Q'
        and then C /= 'U'
        and then C /= 'W'
        and then C /= 'X';
   end Is_OK_Internal_Letter;
 
   ----------------------
   -- Is_Operator_Name --
   ----------------------
 
   function Is_Operator_Name (Id : Name_Id) return Boolean is
      S : Int;
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      S := Name_Entries.Table (Id).Name_Chars_Index;
      return Name_Chars.Table (S + 1) = 'O';
   end Is_Operator_Name;
 
   -------------------
   -- Is_Valid_Name --
   -------------------
 
   function Is_Valid_Name (Id : Name_Id) return Boolean is
   begin
      return Id in Name_Entries.First .. Name_Entries.Last;
   end Is_Valid_Name;
 
   --------------------
   -- Length_Of_Name --
   --------------------
 
   function Length_Of_Name (Id : Name_Id) return Nat is
   begin
      return Int (Name_Entries.Table (Id).Name_Len);
   end Length_Of_Name;
 
   ----------
   -- Lock --
   ----------
 
   procedure Lock is
   begin
      Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
      Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
      Name_Chars.Locked := True;
      Name_Entries.Locked := True;
      Name_Chars.Release;
      Name_Entries.Release;
   end Lock;
 
   ------------------------
   -- Name_Chars_Address --
   ------------------------
 
   function Name_Chars_Address return System.Address is
   begin
      return Name_Chars.Table (0)'Address;
   end Name_Chars_Address;
 
   ----------------
   -- Name_Enter --
   ----------------
 
   function Name_Enter return Name_Id is
   begin
      Name_Entries.Append
        ((Name_Chars_Index      => Name_Chars.Last,
          Name_Len              => Short (Name_Len),
          Byte_Info             => 0,
          Int_Info              => 0,
          Name_Has_No_Encodings => False,
          Hash_Link             => No_Name));
 
      --  Set corresponding string entry in the Name_Chars table
 
      for J in 1 .. Name_Len loop
         Name_Chars.Append (Name_Buffer (J));
      end loop;
 
      Name_Chars.Append (ASCII.NUL);
 
      return Name_Entries.Last;
   end Name_Enter;
 
   --------------------------
   -- Name_Entries_Address --
   --------------------------
 
   function Name_Entries_Address return System.Address is
   begin
      return Name_Entries.Table (First_Name_Id)'Address;
   end Name_Entries_Address;
 
   ------------------------
   -- Name_Entries_Count --
   ------------------------
 
   function Name_Entries_Count return Nat is
   begin
      return Int (Name_Entries.Last - Name_Entries.First + 1);
   end Name_Entries_Count;
 
   ---------------
   -- Name_Find --
   ---------------
 
   function Name_Find return Name_Id is
      New_Id : Name_Id;
      --  Id of entry in hash search, and value to be returned
 
      S : Int;
      --  Pointer into string table
 
      Hash_Index : Hash_Index_Type;
      --  Computed hash index
 
   begin
      --  Quick handling for one character names
 
      if Name_Len = 1 then
         return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
 
      --  Otherwise search hash table for existing matching entry
 
      else
         Hash_Index := Namet.Hash;
         New_Id := Hash_Table (Hash_Index);
 
         if New_Id = No_Name then
            Hash_Table (Hash_Index) := Name_Entries.Last + 1;
 
         else
            Search : loop
               if Name_Len /=
                 Integer (Name_Entries.Table (New_Id).Name_Len)
               then
                  goto No_Match;
               end if;
 
               S := Name_Entries.Table (New_Id).Name_Chars_Index;
 
               for J in 1 .. Name_Len loop
                  if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
                     goto No_Match;
                  end if;
               end loop;
 
               return New_Id;
 
               --  Current entry in hash chain does not match
 
               <<No_Match>>
                  if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
                     New_Id := Name_Entries.Table (New_Id).Hash_Link;
                  else
                     Name_Entries.Table (New_Id).Hash_Link :=
                       Name_Entries.Last + 1;
                     exit Search;
                  end if;
            end loop Search;
         end if;
 
         --  We fall through here only if a matching entry was not found in the
         --  hash table. We now create a new entry in the names table. The hash
         --  link pointing to the new entry (Name_Entries.Last+1) has been set.
 
         Name_Entries.Append
           ((Name_Chars_Index      => Name_Chars.Last,
             Name_Len              => Short (Name_Len),
             Hash_Link             => No_Name,
             Name_Has_No_Encodings => False,
             Int_Info              => 0,
             Byte_Info             => 0));
 
         --  Set corresponding string entry in the Name_Chars table
 
         for J in 1 .. Name_Len loop
            Name_Chars.Append (Name_Buffer (J));
         end loop;
 
         Name_Chars.Append (ASCII.NUL);
 
         return Name_Entries.Last;
      end if;
   end Name_Find;
 
   ------------------
   -- Reinitialize --
   ------------------
 
   procedure Reinitialize is
   begin
      Name_Chars.Init;
      Name_Entries.Init;
 
      --  Initialize entries for one character names
 
      for C in Character loop
         Name_Entries.Append
           ((Name_Chars_Index      => Name_Chars.Last,
             Name_Len              => 1,
             Byte_Info             => 0,
             Int_Info              => 0,
             Name_Has_No_Encodings => True,
             Hash_Link             => No_Name));
 
         Name_Chars.Append (C);
         Name_Chars.Append (ASCII.NUL);
      end loop;
 
      --  Clear hash table
 
      for J in Hash_Index_Type loop
         Hash_Table (J) := No_Name;
      end loop;
   end Reinitialize;
 
   ----------------------
   -- Reset_Name_Table --
   ----------------------
 
   procedure Reset_Name_Table is
   begin
      for J in First_Name_Id .. Name_Entries.Last loop
         Name_Entries.Table (J).Int_Info  := 0;
         Name_Entries.Table (J).Byte_Info := 0;
      end loop;
   end Reset_Name_Table;
 
   --------------------------------
   -- Set_Character_Literal_Name --
   --------------------------------
 
   procedure Set_Character_Literal_Name (C : Char_Code) is
   begin
      Name_Buffer (1) := 'Q';
      Name_Len := 1;
      Store_Encoded_Character (C);
   end Set_Character_Literal_Name;
 
   -------------------------
   -- Set_Name_Table_Byte --
   -------------------------
 
   procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Byte_Info := Val;
   end Set_Name_Table_Byte;
 
   -------------------------
   -- Set_Name_Table_Info --
   -------------------------
 
   procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Int_Info := Val;
   end Set_Name_Table_Info;
 
   -----------------------------
   -- Store_Encoded_Character --
   -----------------------------
 
   procedure Store_Encoded_Character (C : Char_Code) is
 
      procedure Set_Hex_Chars (C : Char_Code);
      --  Stores given value, which is in the range 0 .. 255, as two hex
      --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
 
      -------------------
      -- Set_Hex_Chars --
      -------------------
 
      procedure Set_Hex_Chars (C : Char_Code) is
         Hexd : constant String := "0123456789abcdef";
         N    : constant Natural := Natural (C);
      begin
         Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
         Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
         Name_Len := Name_Len + 2;
      end Set_Hex_Chars;
 
   --  Start of processing for Store_Encoded_Character
 
   begin
      Name_Len := Name_Len + 1;
 
      if In_Character_Range (C) then
         declare
            CC : constant Character := Get_Character (C);
         begin
            if CC in 'a' .. 'z' or else CC in '0' .. '9' then
               Name_Buffer (Name_Len) := CC;
            else
               Name_Buffer (Name_Len) := 'U';
               Set_Hex_Chars (C);
            end if;
         end;
 
      elsif In_Wide_Character_Range (C) then
         Name_Buffer (Name_Len) := 'W';
         Set_Hex_Chars (C / 256);
         Set_Hex_Chars (C mod 256);
 
      else
         Name_Buffer (Name_Len) := 'W';
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := 'W';
         Set_Hex_Chars (C / 2 ** 24);
         Set_Hex_Chars ((C / 2 ** 16) mod 256);
         Set_Hex_Chars ((C / 256) mod 256);
         Set_Hex_Chars (C mod 256);
      end if;
   end Store_Encoded_Character;
 
   --------------------------------------
   -- Strip_Qualification_And_Suffixes --
   --------------------------------------
 
   procedure Strip_Qualification_And_Suffixes is
      J : Integer;
 
   begin
      --  Strip package body qualification string off end
 
      for J in reverse 2 .. Name_Len loop
         if Name_Buffer (J) = 'X' then
            Name_Len := J - 1;
            exit;
         end if;
 
         exit when Name_Buffer (J) /= 'b'
           and then Name_Buffer (J) /= 'n'
           and then Name_Buffer (J) /= 'p';
      end loop;
 
      --  Find rightmost __ or $ separator if one exists. First we position
      --  to start the search. If we have a character constant, position
      --  just before it, otherwise position to last character but one
 
      if Name_Buffer (Name_Len) = ''' then
         J := Name_Len - 2;
         while J > 0 and then Name_Buffer (J) /= ''' loop
            J := J - 1;
         end loop;
 
      else
         J := Name_Len - 1;
      end if;
 
      --  Loop to search for rightmost __ or $ (homonym) separator
 
      while J > 1 loop
 
         --  If $ separator, homonym separator, so strip it and keep looking
 
         if Name_Buffer (J) = '$' then
            Name_Len := J - 1;
            J := Name_Len - 1;
 
         --  Else check for __ found
 
         elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
 
            --  Found __ so see if digit follows, and if so, this is a
            --  homonym separator, so strip it and keep looking.
 
            if Name_Buffer (J + 2) in '0' .. '9' then
               Name_Len := J - 1;
               J := Name_Len - 1;
 
            --  If not a homonym separator, then we simply strip the
            --  separator and everything that precedes it, and we are done
 
            else
               Name_Buffer (1 .. Name_Len - J - 1) :=
                 Name_Buffer (J + 2 .. Name_Len);
               Name_Len := Name_Len - J - 1;
               exit;
            end if;
 
         else
            J := J - 1;
         end if;
      end loop;
   end Strip_Qualification_And_Suffixes;
 
   ---------------
   -- Tree_Read --
   ---------------
 
   procedure Tree_Read is
   begin
      Name_Chars.Tree_Read;
      Name_Entries.Tree_Read;
 
      Tree_Read_Data
        (Hash_Table'Address,
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
   end Tree_Read;
 
   ----------------
   -- Tree_Write --
   ----------------
 
   procedure Tree_Write is
   begin
      Name_Chars.Tree_Write;
      Name_Entries.Tree_Write;
 
      Tree_Write_Data
        (Hash_Table'Address,
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
   end Tree_Write;
 
   ------------
   -- Unlock --
   ------------
 
   procedure Unlock is
   begin
      Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
      Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
      Name_Chars.Locked := False;
      Name_Entries.Locked := False;
      Name_Chars.Release;
      Name_Entries.Release;
   end Unlock;
 
   --------
   -- wn --
   --------
 
   procedure wn (Id : Name_Id) is
      S : Int;
 
   begin
      if not Id'Valid then
         Write_Str ("<invalid name_id>");
 
      elsif Id = No_Name then
         Write_Str ("<No_Name>");
 
      elsif Id = Error_Name then
         Write_Str ("<Error_Name>");
 
      else
         S := Name_Entries.Table (Id).Name_Chars_Index;
         Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
 
         for J in 1 .. Name_Len loop
            Write_Char (Name_Chars.Table (S + Int (J)));
         end loop;
      end if;
 
      Write_Eol;
   end wn;
 
   ----------------
   -- Write_Name --
   ----------------
 
   procedure Write_Name (Id : Name_Id) is
   begin
      if Id >= First_Name_Id then
         Get_Name_String (Id);
         Write_Str (Name_Buffer (1 .. Name_Len));
      end if;
   end Write_Name;
 
   ------------------------
   -- Write_Name_Decoded --
   ------------------------
 
   procedure Write_Name_Decoded (Id : Name_Id) is
   begin
      if Id >= First_Name_Id then
         Get_Decoded_Name_String (Id);
         Write_Str (Name_Buffer (1 .. Name_Len));
      end if;
   end Write_Name_Decoded;
 
--  Package initialization, initialize tables
 
begin
   Reinitialize;
end Namet;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [namet.adb] - Blame information for rev 706

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- N A M E T --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2010, 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. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`-- WARNING: There is a C version of this package. Any changes to this`
33			`-- source file must be properly reflected in the C header file namet.h`
34			`-- which is created manually from namet.ads and namet.adb.`
35
36			`with Debug; use Debug;`
37			`with Opt; use Opt;`
38			`with Output; use Output;`
39			`with Tree_IO; use Tree_IO;`
40			`with Widechar; use Widechar;`