| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- N A M E T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- 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 a-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; |
| |
| 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**12; |
| -- 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 alogorithm. |
| |
| 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 |
| Max_Chain_Length : constant := 50; |
| -- Max length of chains for which specific information is output |
| |
| F : array (Int range 0 .. Max_Chain_Length) of Int; |
| -- N'th entry is number of chains of length N |
| |
| Probes : Int := 0; |
| -- Used to compute average number of probes |
| |
| Nsyms : Int := 0; |
| -- Number of symbols in table |
| |
| begin |
| if Debug_Flag_H then |
| 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 |
| Write_Str ("Hash_Table ("); |
| -- LLVM local |
| Write_Int (J); |
| Write_Str (") has "); |
| |
| declare |
| C : Int := 1; |
| 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; |
| |
| Write_Int (C); |
| Write_Str (" entries"); |
| Write_Eol; |
| |
| if C < Max_Chain_Length then |
| F (C) := F (C) + 1; |
| else |
| F (Max_Chain_Length) := F (Max_Chain_Length) + 1; |
| end if; |
| |
| 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; |
| end if; |
| end loop; |
| |
| Write_Eol; |
| |
| for J in Int range 0 .. Max_Chain_Length 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 = Max_Chain_Length then |
| Write_Str (" or greater"); |
| end if; |
| |
| Write_Str (" = "); |
| Write_Int (F (J)); |
| Write_Eol; |
| |
| if J /= 0 then |
| Nsyms := Nsyms + F (J); |
| Probes := Probes + F (J) * (1 + J) * 100; |
| end if; |
| end if; |
| end loop; |
| |
| 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 (48 + Probes / 10)); |
| Write_Char (Character'Val (48 + Probes mod 10)); |
| Write_Eol; |
| Write_Eol; |
| end if; |
| end Finalize; |
| |
| ----------------------------- |
| -- Get_Decoded_Name_String -- |
| ----------------------------- |
| |
| procedure Get_Decoded_Name_String (Id : Name_Id) is |
| C : Character; |
| P : Natural; |
| |
| begin |
| Get_Name_String (Id); |
| |
| -- Quick loop to see if there is anything special to do |
| |
| P := 1; |
| loop |
| if P = Name_Len then |
| 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 |
| -- 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 |
| begin |
| -- For the cases of 1-12 characters, all characters participate in the |
| -- hash. The positioning is randomized, with the bias that characters |
| -- later on participate fully (i.e. are added towards the right side). |
| |
| case Name_Len is |
| |
| when 0 => |
| return 0; |
| |
| when 1 => |
| return |
| Character'Pos (Name_Buffer (1)); |
| |
| when 2 => |
| return (( |
| Character'Pos (Name_Buffer (1))) * 64 + |
| Character'Pos (Name_Buffer (2))) mod Hash_Num; |
| |
| when 3 => |
| return ((( |
| Character'Pos (Name_Buffer (1))) * 16 + |
| Character'Pos (Name_Buffer (3))) * 16 + |
| Character'Pos (Name_Buffer (2))) mod Hash_Num; |
| |
| when 4 => |
| return (((( |
| Character'Pos (Name_Buffer (1))) * 8 + |
| Character'Pos (Name_Buffer (2))) * 8 + |
| Character'Pos (Name_Buffer (3))) * 8 + |
| Character'Pos (Name_Buffer (4))) mod Hash_Num; |
| |
| when 5 => |
| return ((((( |
| Character'Pos (Name_Buffer (4))) * 8 + |
| Character'Pos (Name_Buffer (1))) * 4 + |
| Character'Pos (Name_Buffer (3))) * 4 + |
| Character'Pos (Name_Buffer (5))) * 8 + |
| Character'Pos (Name_Buffer (2))) mod Hash_Num; |
| |
| when 6 => |
| return (((((( |
| Character'Pos (Name_Buffer (5))) * 4 + |
| Character'Pos (Name_Buffer (1))) * 4 + |
| Character'Pos (Name_Buffer (4))) * 4 + |
| Character'Pos (Name_Buffer (2))) * 4 + |
| Character'Pos (Name_Buffer (6))) * 4 + |
| Character'Pos (Name_Buffer (3))) mod Hash_Num; |
| |
| when 7 => |
| return ((((((( |
| Character'Pos (Name_Buffer (4))) * 4 + |
| Character'Pos (Name_Buffer (3))) * 4 + |
| Character'Pos (Name_Buffer (1))) * 4 + |
| Character'Pos (Name_Buffer (2))) * 2 + |
| Character'Pos (Name_Buffer (5))) * 2 + |
| Character'Pos (Name_Buffer (7))) * 2 + |
| Character'Pos (Name_Buffer (6))) mod Hash_Num; |
| |
| when 8 => |
| return (((((((( |
| Character'Pos (Name_Buffer (2))) * 4 + |
| Character'Pos (Name_Buffer (1))) * 4 + |
| Character'Pos (Name_Buffer (3))) * 2 + |
| Character'Pos (Name_Buffer (5))) * 2 + |
| Character'Pos (Name_Buffer (7))) * 2 + |
| Character'Pos (Name_Buffer (6))) * 2 + |
| Character'Pos (Name_Buffer (4))) * 2 + |
| Character'Pos (Name_Buffer (8))) mod Hash_Num; |
| |
| when 9 => |
| return ((((((((( |
| Character'Pos (Name_Buffer (2))) * 4 + |
| Character'Pos (Name_Buffer (1))) * 4 + |
| Character'Pos (Name_Buffer (3))) * 4 + |
| Character'Pos (Name_Buffer (4))) * 2 + |
| Character'Pos (Name_Buffer (8))) * 2 + |
| Character'Pos (Name_Buffer (7))) * 2 + |
| Character'Pos (Name_Buffer (5))) * 2 + |
| Character'Pos (Name_Buffer (6))) * 2 + |
| Character'Pos (Name_Buffer (9))) mod Hash_Num; |
| |
| when 10 => |
| return (((((((((( |
| Character'Pos (Name_Buffer (01))) * 2 + |
| Character'Pos (Name_Buffer (02))) * 2 + |
| Character'Pos (Name_Buffer (08))) * 2 + |
| Character'Pos (Name_Buffer (03))) * 2 + |
| Character'Pos (Name_Buffer (04))) * 2 + |
| Character'Pos (Name_Buffer (09))) * 2 + |
| Character'Pos (Name_Buffer (06))) * 2 + |
| Character'Pos (Name_Buffer (05))) * 2 + |
| Character'Pos (Name_Buffer (07))) * 2 + |
| Character'Pos (Name_Buffer (10))) mod Hash_Num; |
| |
| when 11 => |
| return ((((((((((( |
| Character'Pos (Name_Buffer (05))) * 2 + |
| Character'Pos (Name_Buffer (01))) * 2 + |
| Character'Pos (Name_Buffer (06))) * 2 + |
| Character'Pos (Name_Buffer (09))) * 2 + |
| Character'Pos (Name_Buffer (07))) * 2 + |
| Character'Pos (Name_Buffer (03))) * 2 + |
| Character'Pos (Name_Buffer (08))) * 2 + |
| Character'Pos (Name_Buffer (02))) * 2 + |
| Character'Pos (Name_Buffer (10))) * 2 + |
| Character'Pos (Name_Buffer (04))) * 2 + |
| Character'Pos (Name_Buffer (11))) mod Hash_Num; |
| |
| when 12 => |
| return (((((((((((( |
| Character'Pos (Name_Buffer (03))) * 2 + |
| Character'Pos (Name_Buffer (02))) * 2 + |
| Character'Pos (Name_Buffer (05))) * 2 + |
| Character'Pos (Name_Buffer (01))) * 2 + |
| Character'Pos (Name_Buffer (06))) * 2 + |
| Character'Pos (Name_Buffer (04))) * 2 + |
| Character'Pos (Name_Buffer (08))) * 2 + |
| Character'Pos (Name_Buffer (11))) * 2 + |
| Character'Pos (Name_Buffer (07))) * 2 + |
| Character'Pos (Name_Buffer (09))) * 2 + |
| Character'Pos (Name_Buffer (10))) * 2 + |
| Character'Pos (Name_Buffer (12))) mod Hash_Num; |
| |
| -- Names longer than 12 characters are handled by taking the first |
| -- 6 odd numbered characters and the last 6 even numbered characters. |
| |
| when others => declare |
| Even_Name_Len : constant Integer := (Name_Len) / 2 * 2; |
| begin |
| return (((((((((((( |
| Character'Pos (Name_Buffer (01))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + |
| Character'Pos (Name_Buffer (03))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + |
| Character'Pos (Name_Buffer (05))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + |
| Character'Pos (Name_Buffer (07))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + |
| Character'Pos (Name_Buffer (09))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + |
| Character'Pos (Name_Buffer (11))) * 2 + |
| Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; |
| end; |
| end case; |
| end Hash; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| Name_Chars.Init; |
| Name_Entries.Init; |
| |
| -- Initialize entries for one character names |
| |
| for C in Character loop |
| Name_Entries.Increment_Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := |
| Name_Chars.Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Len := 1; |
| Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; |
| Name_Entries.Table (Name_Entries.Last).Int_Info := 0; |
| Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := C; |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; |
| end loop; |
| |
| -- Clear hash table |
| |
| for J in Hash_Index_Type loop |
| Hash_Table (J) := No_Name; |
| end loop; |
| end Initialize; |
| |
| ---------------------- |
| -- 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; |
| |
| -------------------- |
| -- 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.Increment_Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := |
| Name_Chars.Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); |
| Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; |
| Name_Entries.Table (Name_Entries.Last).Int_Info := 0; |
| Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; |
| |
| -- Set corresponding string entry in the Name_Chars table |
| |
| for J in 1 .. Name_Len loop |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J); |
| end loop; |
| |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := 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.Increment_Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := |
| Name_Chars.Last; |
| Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); |
| Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; |
| Name_Entries.Table (Name_Entries.Last).Int_Info := 0; |
| Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; |
| |
| -- Set corresponding string entry in the Name_Chars table |
| |
| for J in 1 .. Name_Len loop |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J); |
| end loop; |
| |
| Name_Chars.Increment_Last; |
| Name_Chars.Table (Name_Chars.Last) := ASCII.NUL; |
| |
| return Name_Entries.Last; |
| end if; |
| end Name_Find; |
| |
| ---------------------- |
| -- 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 |
| begin |
| Write_Name (Id); |
| 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; |
| |
| end Namet; |
