1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
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.
36 with Debug; use Debug;
38 with Output; use Output;
39 with Tree_IO; use Tree_IO;
40 with Widechar; use Widechar;
42 with Interfaces; use Interfaces;
46 Name_Chars_Reserve : constant := 5000;
47 Name_Entries_Reserve : constant := 100;
48 -- The names table is locked during gigi processing, since gigi assumes
49 -- that the table does not move. After returning from gigi, the names
50 -- table is unlocked again, since writing library file information needs
51 -- to generate some extra names. To avoid the inefficiency of always
52 -- reallocating during this second unlocked phase, we reserve a bit of
53 -- extra space before doing the release call.
55 Hash_Num : constant Int := 2**16;
56 -- Number of headers in the hash table. Current hash algorithm is closely
57 -- tailored to this choice, so it can only be changed if a corresponding
58 -- change is made to the hash algorithm.
60 Hash_Max : constant Int := Hash_Num - 1;
61 -- Indexes in the hash header table run from 0 to Hash_Num - 1
63 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
64 -- Range of hash index values
66 Hash_Table : array (Hash_Index_Type) of Name_Id;
67 -- The hash table is used to locate existing entries in the names table.
68 -- The entries point to the first names table entry whose hash value
69 -- matches the hash code. Then subsequent names table entries with the
70 -- same hash code value are linked through the Hash_Link fields.
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 function Hash (Buf : Bounded_String) return Hash_Index_Type;
78 -- Compute hash code for name stored in Buf
80 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String);
81 -- Given an encoded entity name in Buf, remove package body
82 -- suffix as described for Strip_Package_Body_Suffix, and also remove
83 -- all qualification, i.e. names followed by two underscores.
85 -----------------------------
86 -- Add_Char_To_Name_Buffer --
87 -----------------------------
89 procedure Add_Char_To_Name_Buffer (C : Character) is
91 Append (Global_Name_Buffer, C);
92 end Add_Char_To_Name_Buffer;
94 ----------------------------
95 -- Add_Nat_To_Name_Buffer --
96 ----------------------------
98 procedure Add_Nat_To_Name_Buffer (V : Nat) is
100 Append (Global_Name_Buffer, V);
101 end Add_Nat_To_Name_Buffer;
103 ----------------------------
104 -- Add_Str_To_Name_Buffer --
105 ----------------------------
107 procedure Add_Str_To_Name_Buffer (S : String) is
109 Append (Global_Name_Buffer, S);
110 end Add_Str_To_Name_Buffer;
116 procedure Append (Buf : in out Bounded_String; C : Character) is
118 if Buf.Length < Buf.Chars'Last then
119 Buf.Length := Buf.Length + 1;
120 Buf.Chars (Buf.Length) := C;
124 procedure Append (Buf : in out Bounded_String; V : Nat) is
127 Append (Buf, V / 10);
130 Append (Buf, Character'Val (Character'Pos ('0') + V rem 10));
133 procedure Append (Buf : in out Bounded_String; S : String) is
135 for J in S'Range loop
140 procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
141 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
142 S : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
144 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
145 Append (Buf, Name_Chars.Table (S + Int (J)));
153 procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is
160 -- Skip scan if we already know there are no encodings
162 if Name_Entries.Table (Id).Name_Has_No_Encodings then
166 -- Quick loop to see if there is anything special to do
170 if P = Buf.Length then
171 Name_Entries.Table (Id).Name_Has_No_Encodings := True;
187 -- Here we have at least some encoding that we must decode
192 New_Buf : String (1 .. Buf.Chars'Last);
194 procedure Copy_One_Character;
195 -- Copy a character from Buf.Chars to New_Buf. Includes case
196 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
198 function Hex (N : Natural) return Word;
199 -- Scans past N digits using Old pointer and returns hex value
201 procedure Insert_Character (C : Character);
202 -- Insert a new character into output decoded name
204 ------------------------
205 -- Copy_One_Character --
206 ------------------------
208 procedure Copy_One_Character is
212 C := Buf.Chars (Old);
214 -- U (upper half insertion case)
217 and then Old < Buf.Length
218 and then Buf.Chars (Old + 1) not in 'A' .. 'Z'
219 and then Buf.Chars (Old + 1) /= '_'
223 -- If we have upper half encoding, then we have to set an
224 -- appropriate wide character sequence for this character.
226 if Upper_Half_Encoding then
227 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
229 -- For other encoding methods, upper half characters can
230 -- simply use their normal representation.
233 Insert_Character (Character'Val (Hex (2)));
236 -- WW (wide wide character insertion)
239 and then Old < Buf.Length
240 and then Buf.Chars (Old + 1) = 'W'
243 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
245 -- W (wide character insertion)
248 and then Old < Buf.Length
249 and then Buf.Chars (Old + 1) not in 'A' .. 'Z'
250 and then Buf.Chars (Old + 1) /= '_'
253 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
255 -- Any other character is copied unchanged
258 Insert_Character (C);
261 end Copy_One_Character;
267 function Hex (N : Natural) return Word is
273 C := Buf.Chars (Old);
276 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
279 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
280 else -- C in 'a' .. 'f'
281 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
288 ----------------------
289 -- Insert_Character --
290 ----------------------
292 procedure Insert_Character (C : Character) is
294 New_Len := New_Len + 1;
295 New_Buf (New_Len) := C;
296 end Insert_Character;
298 -- Start of processing for Decode
304 -- Loop through characters of name
306 while Old <= Buf.Length loop
308 -- Case of character literal, put apostrophes around character
310 if Buf.Chars (Old) = 'Q'
311 and then Old < Buf.Length
314 Insert_Character (''');
316 Insert_Character (''');
318 -- Case of operator name
320 elsif Buf.Chars (Old) = 'O'
321 and then Old < Buf.Length
322 and then Buf.Chars (Old + 1) not in 'A' .. 'Z'
323 and then Buf.Chars (Old + 1) /= '_'
328 -- This table maps the 2nd and 3rd characters of the name
329 -- into the required output. Two blanks means leave the
332 Map : constant String :=
333 "ab " & -- Oabs => "abs"
334 "ad+ " & -- Oadd => "+"
335 "an " & -- Oand => "and"
336 "co& " & -- Oconcat => "&"
337 "di/ " & -- Odivide => "/"
338 "eq= " & -- Oeq => "="
339 "ex**" & -- Oexpon => "**"
340 "gt> " & -- Ogt => ">"
341 "ge>=" & -- Oge => ">="
342 "le<=" & -- Ole => "<="
343 "lt< " & -- Olt => "<"
344 "mo " & -- Omod => "mod"
345 "mu* " & -- Omutliply => "*"
346 "ne/=" & -- One => "/="
347 "no " & -- Onot => "not"
348 "or " & -- Oor => "or"
349 "re " & -- Orem => "rem"
350 "su- " & -- Osubtract => "-"
351 "xo "; -- Oxor => "xor"
356 Insert_Character ('"');
358 -- Search the map. Note that this loop must terminate, if
359 -- not we have some kind of internal error, and a constraint
360 -- error may be raised.
364 exit when Buf.Chars (Old) = Map (J)
365 and then Buf.Chars (Old + 1) = Map (J + 1);
369 -- Special operator name
371 if Map (J + 2) /= ' ' then
372 Insert_Character (Map (J + 2));
374 if Map (J + 3) /= ' ' then
375 Insert_Character (Map (J + 3));
378 Insert_Character ('"');
380 -- Skip past original operator name in input
382 while Old <= Buf.Length
383 and then Buf.Chars (Old) in 'a' .. 'z'
388 -- For other operator names, leave them in lower case,
389 -- surrounded by apostrophes
392 -- Copy original operator name from input to output
394 while Old <= Buf.Length
395 and then Buf.Chars (Old) in 'a' .. 'z'
400 Insert_Character ('"');
404 -- Else copy one character and keep going
411 -- Copy new buffer as result
413 Buf.Length := New_Len;
414 Buf.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
418 ----------------------------------
419 -- Append_Decoded_With_Brackets --
420 ----------------------------------
422 procedure Append_Decoded_With_Brackets
423 (Buf : in out Bounded_String; Id : Name_Id) is
427 -- Case of operator name, normal decoding is fine
429 if Buf.Chars (1) = 'O' then
430 Append_Decoded (Buf, Id);
432 -- For character literals, normal decoding is fine
434 elsif Buf.Chars (1) = 'Q' then
435 Append_Decoded (Buf, Id);
437 -- Only remaining issue is U/W/WW sequences
443 while P < Buf.Length loop
444 if Buf.Chars (P + 1) in 'A' .. 'Z' then
449 elsif Buf.Chars (P) = 'U' then
450 for J in reverse P + 3 .. P + Buf.Length loop
451 Buf.Chars (J + 3) := Buf.Chars (J);
454 Buf.Length := Buf.Length + 3;
455 Buf.Chars (P + 3) := Buf.Chars (P + 2);
456 Buf.Chars (P + 2) := Buf.Chars (P + 1);
457 Buf.Chars (P) := '[';
458 Buf.Chars (P + 1) := '"';
459 Buf.Chars (P + 4) := '"';
460 Buf.Chars (P + 5) := ']';
463 -- WWhhhhhhhh encoding
465 elsif Buf.Chars (P) = 'W'
466 and then P + 9 <= Buf.Length
467 and then Buf.Chars (P + 1) = 'W'
468 and then Buf.Chars (P + 2) not in 'A' .. 'Z'
469 and then Buf.Chars (P + 2) /= '_'
471 Buf.Chars (P + 12 .. Buf.Length + 2) :=
472 Buf.Chars (P + 10 .. Buf.Length);
473 Buf.Chars (P) := '[';
474 Buf.Chars (P + 1) := '"';
475 Buf.Chars (P + 10) := '"';
476 Buf.Chars (P + 11) := ']';
477 Buf.Length := Buf.Length + 2;
482 elsif Buf.Chars (P) = 'W'
483 and then P < Buf.Length
484 and then Buf.Chars (P + 1) not in 'A' .. 'Z'
485 and then Buf.Chars (P + 1) /= '_'
487 Buf.Chars (P + 8 .. P + Buf.Length + 3) :=
488 Buf.Chars (P + 5 .. Buf.Length);
489 Buf.Chars (P + 2 .. P + 5) := Buf.Chars (P + 1 .. P + 4);
490 Buf.Chars (P) := '[';
491 Buf.Chars (P + 1) := '"';
492 Buf.Chars (P + 6) := '"';
493 Buf.Chars (P + 7) := ']';
494 Buf.Length := Buf.Length + 3;
502 end Append_Decoded_With_Brackets;
508 procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is
509 procedure Set_Hex_Chars (C : Char_Code);
510 -- Stores given value, which is in the range 0 .. 255, as two hex
511 -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length.
517 procedure Set_Hex_Chars (C : Char_Code) is
518 Hexd : constant String := "0123456789abcdef";
519 N : constant Natural := Natural (C);
521 Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1);
522 Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1);
523 Buf.Length := Buf.Length + 2;
526 -- Start of processing for Append_Encoded
529 Buf.Length := Buf.Length + 1;
531 if In_Character_Range (C) then
533 CC : constant Character := Get_Character (C);
535 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
536 Buf.Chars (Buf.Length) := CC;
538 Buf.Chars (Buf.Length) := 'U';
543 elsif In_Wide_Character_Range (C) then
544 Buf.Chars (Buf.Length) := 'W';
545 Set_Hex_Chars (C / 256);
546 Set_Hex_Chars (C mod 256);
549 Buf.Chars (Buf.Length) := 'W';
550 Buf.Length := Buf.Length + 1;
551 Buf.Chars (Buf.Length) := 'W';
552 Set_Hex_Chars (C / 2 ** 24);
553 Set_Hex_Chars ((C / 2 ** 16) mod 256);
554 Set_Hex_Chars ((C / 256) mod 256);
555 Set_Hex_Chars (C mod 256);
559 ------------------------
560 -- Append_Unqualified --
561 ------------------------
563 procedure Append_Unqualified
564 (Buf : in out Bounded_String; Id : Name_Id) is
567 Strip_Qualification_And_Suffixes (Buf);
568 end Append_Unqualified;
570 --------------------------------
571 -- Append_Unqualified_Decoded --
572 --------------------------------
574 procedure Append_Unqualified_Decoded
575 (Buf : in out Bounded_String; Id : Name_Id) is
577 Append_Decoded (Buf, Id);
578 Strip_Qualification_And_Suffixes (Buf);
579 end Append_Unqualified_Decoded;
585 procedure Finalize is
586 F : array (Int range 0 .. 50) of Int;
587 -- N'th entry is the number of chains of length N, except last entry,
588 -- which is the number of chains of length F'Last or more.
590 Max_Chain_Length : Int := 0;
591 -- Maximum length of all chains
594 -- Used to compute average number of probes
597 -- Number of symbols in table
599 Verbosity : constant Int range 1 .. 3 := 1;
600 pragma Warnings (Off, Verbosity);
601 -- This constant indicates the level of verbosity in the output from
602 -- this procedure. Currently this can only be changed by editing the
603 -- declaration above and recompiling. That's good enough in practice,
604 -- since we very rarely need to use this debug option. Settings are:
606 -- 1 => print basic summary information
607 -- 2 => in addition print number of entries per hash chain
608 -- 3 => in addition print content of entries
610 Zero : constant Int := Character'Pos ('0');
613 if not Debug_Flag_H then
617 for J in F'Range loop
621 for J in Hash_Index_Type loop
622 if Hash_Table (J) = No_Name then
635 while N /= No_Name loop
636 N := Name_Entries.Table (N).Hash_Link;
641 Probes := Probes + (1 + C) * 100;
643 if C > Max_Chain_Length then
644 Max_Chain_Length := C;
647 if Verbosity >= 2 then
648 Write_Str ("Hash_Table (");
650 Write_Str (") has ");
652 Write_Str (" entries");
659 F (F'Last) := F (F'Last) + 1;
662 if Verbosity >= 3 then
664 while N /= No_Name loop
665 S := Name_Entries.Table (N).Name_Chars_Index;
669 for J in 1 .. Name_Entries.Table (N).Name_Len loop
670 Write_Char (Name_Chars.Table (S + Int (J)));
675 N := Name_Entries.Table (N).Hash_Link;
684 for J in F'Range loop
686 Write_Str ("Number of hash chains of length ");
695 Write_Str (" or greater");
704 -- Print out average number of probes, in the case where Name_Find is
705 -- called for a string that is already in the table.
708 Write_Str ("Average number of probes for lookup = ");
709 Probes := Probes / Nsyms;
710 Write_Int (Probes / 200);
712 Probes := (Probes mod 200) / 2;
713 Write_Char (Character'Val (Zero + Probes / 10));
714 Write_Char (Character'Val (Zero + Probes mod 10));
717 Write_Str ("Max_Chain_Length = ");
718 Write_Int (Max_Chain_Length);
720 Write_Str ("Name_Chars'Length = ");
721 Write_Int (Name_Chars.Last - Name_Chars.First + 1);
723 Write_Str ("Name_Entries'Length = ");
724 Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
726 Write_Str ("Nsyms = ");
731 -----------------------------
732 -- Get_Decoded_Name_String --
733 -----------------------------
735 procedure Get_Decoded_Name_String (Id : Name_Id) is
737 Global_Name_Buffer.Length := 0;
738 Append_Decoded (Global_Name_Buffer, Id);
739 end Get_Decoded_Name_String;
741 -------------------------------------------
742 -- Get_Decoded_Name_String_With_Brackets --
743 -------------------------------------------
745 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
747 Global_Name_Buffer.Length := 0;
748 Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
749 end Get_Decoded_Name_String_With_Brackets;
751 ------------------------
752 -- Get_Last_Two_Chars --
753 ------------------------
755 procedure Get_Last_Two_Chars
760 NE : Name_Entry renames Name_Entries.Table (N);
761 NEL : constant Int := Int (NE.Name_Len);
765 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
766 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
771 end Get_Last_Two_Chars;
773 ---------------------
774 -- Get_Name_String --
775 ---------------------
777 procedure Get_Name_String (Id : Name_Id) is
779 Global_Name_Buffer.Length := 0;
780 Append (Global_Name_Buffer, Id);
783 function Get_Name_String (Id : Name_Id) return String is
784 Buf : Bounded_String;
790 --------------------------------
791 -- Get_Name_String_And_Append --
792 --------------------------------
794 procedure Get_Name_String_And_Append (Id : Name_Id) is
796 Append (Global_Name_Buffer, Id);
797 end Get_Name_String_And_Append;
799 -----------------------------
800 -- Get_Name_Table_Boolean1 --
801 -----------------------------
803 function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is
805 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
806 return Name_Entries.Table (Id).Boolean1_Info;
807 end Get_Name_Table_Boolean1;
809 -----------------------------
810 -- Get_Name_Table_Boolean2 --
811 -----------------------------
813 function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is
815 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
816 return Name_Entries.Table (Id).Boolean2_Info;
817 end Get_Name_Table_Boolean2;
819 -----------------------------
820 -- Get_Name_Table_Boolean3 --
821 -----------------------------
823 function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is
825 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
826 return Name_Entries.Table (Id).Boolean3_Info;
827 end Get_Name_Table_Boolean3;
829 -------------------------
830 -- Get_Name_Table_Byte --
831 -------------------------
833 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
835 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
836 return Name_Entries.Table (Id).Byte_Info;
837 end Get_Name_Table_Byte;
839 -------------------------
840 -- Get_Name_Table_Int --
841 -------------------------
843 function Get_Name_Table_Int (Id : Name_Id) return Int is
845 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
846 return Name_Entries.Table (Id).Int_Info;
847 end Get_Name_Table_Int;
849 -----------------------------------------
850 -- Get_Unqualified_Decoded_Name_String --
851 -----------------------------------------
853 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
855 Global_Name_Buffer.Length := 0;
856 Append_Unqualified_Decoded (Global_Name_Buffer, Id);
857 end Get_Unqualified_Decoded_Name_String;
859 ---------------------------------
860 -- Get_Unqualified_Name_String --
861 ---------------------------------
863 procedure Get_Unqualified_Name_String (Id : Name_Id) is
865 Global_Name_Buffer.Length := 0;
866 Append_Unqualified (Global_Name_Buffer, Id);
867 end Get_Unqualified_Name_String;
873 function Hash (Buf : Bounded_String) return Hash_Index_Type is
875 -- This hash function looks at every character, in order to make it
876 -- likely that similar strings get different hash values. The rotate by
877 -- 7 bits has been determined empirically to be good, and it doesn't
878 -- lose bits like a shift would. The final conversion can't overflow,
879 -- because the table is 2**16 in size. This function probably needs to
880 -- be changed if the hash table size is changed.
882 -- Note that we could get some speed improvement by aligning the string
883 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement
884 -- a growable table. It doesn't seem worth the trouble to do those
887 Result : Unsigned_16 := 0;
890 for J in 1 .. Buf.Length loop
891 Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J));
894 return Hash_Index_Type (Result);
901 procedure Initialize is
911 (Buf : in out Bounded_String; S : String; Index : Positive) is
912 SL : constant Natural := S'Length;
914 Buf.Chars (Index + SL .. Buf.Length + SL) :=
915 Buf.Chars (Index .. Buf.Length);
916 Buf.Chars (Index .. Index + SL - 1) := S;
917 Buf.Length := Buf.Length + SL;
920 -------------------------------
921 -- Insert_Str_In_Name_Buffer --
922 -------------------------------
924 procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
926 Insert_Str (Global_Name_Buffer, S, Index);
927 end Insert_Str_In_Name_Buffer;
929 ----------------------
930 -- Is_Internal_Name --
931 ----------------------
933 function Is_Internal_Name (Buf : Bounded_String) return Boolean is
937 -- Any name starting or ending with underscore is internal
939 if Buf.Chars (1) = '_'
940 or else Buf.Chars (Buf.Length) = '_'
944 -- Allow quoted character
946 elsif Buf.Chars (1) = ''' then
949 -- All other cases, scan name
952 -- Test backwards, because we only want to test the last entity
953 -- name if the name we have is qualified with other entities.
958 -- Skip stuff between brackets (A-F OK there)
960 if Buf.Chars (J) = ']' then
963 exit when J = 1 or else Buf.Chars (J) = '[';
966 -- Test for internal letter
968 elsif Is_OK_Internal_Letter (Buf.Chars (J)) then
971 -- Quit if we come to terminating double underscore (note that
972 -- if the current character is an underscore, we know that
973 -- there is a previous character present, since we already
974 -- filtered out the case of Buf.Chars (1) = '_' above.
976 elsif Buf.Chars (J) = '_'
977 and then Buf.Chars (J - 1) = '_'
978 and then Buf.Chars (J - 2) /= '_'
988 end Is_Internal_Name;
990 function Is_Internal_Name (Id : Name_Id) return Boolean is
991 Buf : Bounded_String;
993 if Id in Error_Name_Or_No_Name then
997 return Is_Internal_Name (Buf);
999 end Is_Internal_Name;
1001 function Is_Internal_Name return Boolean is
1003 return Is_Internal_Name (Global_Name_Buffer);
1004 end Is_Internal_Name;
1006 ---------------------------
1007 -- Is_OK_Internal_Letter --
1008 ---------------------------
1010 function Is_OK_Internal_Letter (C : Character) return Boolean is
1012 return C in 'A' .. 'Z'
1018 end Is_OK_Internal_Letter;
1020 ----------------------
1021 -- Is_Operator_Name --
1022 ----------------------
1024 function Is_Operator_Name (Id : Name_Id) return Boolean is
1027 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1028 S := Name_Entries.Table (Id).Name_Chars_Index;
1029 return Name_Chars.Table (S + 1) = 'O';
1030 end Is_Operator_Name;
1036 function Is_Valid_Name (Id : Name_Id) return Boolean is
1038 return Id in Name_Entries.First .. Name_Entries.Last;
1041 --------------------
1042 -- Length_Of_Name --
1043 --------------------
1045 function Length_Of_Name (Id : Name_Id) return Nat is
1047 return Int (Name_Entries.Table (Id).Name_Len);
1056 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
1057 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
1058 Name_Chars.Locked := True;
1059 Name_Entries.Locked := True;
1061 Name_Entries.Release;
1064 ------------------------
1065 -- Name_Chars_Address --
1066 ------------------------
1068 function Name_Chars_Address return System.Address is
1070 return Name_Chars.Table (0)'Address;
1071 end Name_Chars_Address;
1078 (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
1082 ((Name_Chars_Index => Name_Chars.Last,
1083 Name_Len => Short (Buf.Length),
1086 Boolean1_Info => False,
1087 Boolean2_Info => False,
1088 Boolean3_Info => False,
1089 Name_Has_No_Encodings => False,
1090 Hash_Link => No_Name));
1092 -- Set corresponding string entry in the Name_Chars table
1094 for J in 1 .. Buf.Length loop
1095 Name_Chars.Append (Buf.Chars (J));
1098 Name_Chars.Append (ASCII.NUL);
1100 return Name_Entries.Last;
1103 --------------------------
1104 -- Name_Entries_Address --
1105 --------------------------
1107 function Name_Entries_Address return System.Address is
1109 return Name_Entries.Table (First_Name_Id)'Address;
1110 end Name_Entries_Address;
1112 ------------------------
1113 -- Name_Entries_Count --
1114 ------------------------
1116 function Name_Entries_Count return Nat is
1118 return Int (Name_Entries.Last - Name_Entries.First + 1);
1119 end Name_Entries_Count;
1126 (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
1129 -- Id of entry in hash search, and value to be returned
1132 -- Pointer into string table
1134 Hash_Index : Hash_Index_Type;
1135 -- Computed hash index
1138 -- Quick handling for one character names
1140 if Buf.Length = 1 then
1141 return Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
1143 -- Otherwise search hash table for existing matching entry
1146 Hash_Index := Namet.Hash (Buf);
1147 New_Id := Hash_Table (Hash_Index);
1149 if New_Id = No_Name then
1150 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1155 Integer (Name_Entries.Table (New_Id).Name_Len)
1160 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1162 for J in 1 .. Buf.Length loop
1163 if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then
1170 -- Current entry in hash chain does not match
1173 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1174 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1176 Name_Entries.Table (New_Id).Hash_Link :=
1177 Name_Entries.Last + 1;
1183 -- We fall through here only if a matching entry was not found in the
1184 -- hash table. We now create a new entry in the names table. The hash
1185 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1188 ((Name_Chars_Index => Name_Chars.Last,
1189 Name_Len => Short (Buf.Length),
1190 Hash_Link => No_Name,
1191 Name_Has_No_Encodings => False,
1194 Boolean1_Info => False,
1195 Boolean2_Info => False,
1196 Boolean3_Info => False));
1198 -- Set corresponding string entry in the Name_Chars table
1200 for J in 1 .. Buf.Length loop
1201 Name_Chars.Append (Buf.Chars (J));
1204 Name_Chars.Append (ASCII.NUL);
1206 return Name_Entries.Last;
1210 function Name_Find (S : String) return Name_Id is
1211 Buf : Bounded_String;
1214 return Name_Find (Buf);
1224 V2 : Name_Id) return Boolean
1227 return T = V1 or else
1235 V3 : Name_Id) return Boolean
1238 return T = V1 or else
1248 V4 : Name_Id) return Boolean
1251 return T = V1 or else
1263 V5 : Name_Id) return Boolean
1266 return T = V1 or else
1280 V6 : Name_Id) return Boolean
1283 return T = V1 or else
1299 V7 : Name_Id) return Boolean
1302 return T = V1 or else
1320 V8 : Name_Id) return Boolean
1323 return T = V1 or else
1343 V9 : Name_Id) return Boolean
1346 return T = V1 or else
1368 V10 : Name_Id) return Boolean
1371 return T = V1 or else
1395 V11 : Name_Id) return Boolean
1398 return T = V1 or else
1415 function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is
1417 return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
1424 procedure Reinitialize is
1429 -- Initialize entries for one character names
1431 for C in Character loop
1433 ((Name_Chars_Index => Name_Chars.Last,
1437 Boolean1_Info => False,
1438 Boolean2_Info => False,
1439 Boolean3_Info => False,
1440 Name_Has_No_Encodings => True,
1441 Hash_Link => No_Name));
1443 Name_Chars.Append (C);
1444 Name_Chars.Append (ASCII.NUL);
1449 for J in Hash_Index_Type loop
1450 Hash_Table (J) := No_Name;
1454 ----------------------
1455 -- Reset_Name_Table --
1456 ----------------------
1458 procedure Reset_Name_Table is
1460 for J in First_Name_Id .. Name_Entries.Last loop
1461 Name_Entries.Table (J).Int_Info := 0;
1462 Name_Entries.Table (J).Byte_Info := 0;
1464 end Reset_Name_Table;
1466 --------------------------------
1467 -- Set_Character_Literal_Name --
1468 --------------------------------
1470 procedure Set_Character_Literal_Name
1471 (Buf : in out Bounded_String; C : Char_Code) is
1475 Append_Encoded (Buf, C);
1476 end Set_Character_Literal_Name;
1478 procedure Set_Character_Literal_Name (C : Char_Code) is
1480 Set_Character_Literal_Name (Global_Name_Buffer, C);
1481 end Set_Character_Literal_Name;
1483 -----------------------------
1484 -- Set_Name_Table_Boolean1 --
1485 -----------------------------
1487 procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
1489 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1490 Name_Entries.Table (Id).Boolean1_Info := Val;
1491 end Set_Name_Table_Boolean1;
1493 -----------------------------
1494 -- Set_Name_Table_Boolean2 --
1495 -----------------------------
1497 procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
1499 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1500 Name_Entries.Table (Id).Boolean2_Info := Val;
1501 end Set_Name_Table_Boolean2;
1503 -----------------------------
1504 -- Set_Name_Table_Boolean3 --
1505 -----------------------------
1507 procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
1509 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1510 Name_Entries.Table (Id).Boolean3_Info := Val;
1511 end Set_Name_Table_Boolean3;
1513 -------------------------
1514 -- Set_Name_Table_Byte --
1515 -------------------------
1517 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1519 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1520 Name_Entries.Table (Id).Byte_Info := Val;
1521 end Set_Name_Table_Byte;
1523 -------------------------
1524 -- Set_Name_Table_Int --
1525 -------------------------
1527 procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is
1529 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1530 Name_Entries.Table (Id).Int_Info := Val;
1531 end Set_Name_Table_Int;
1533 -----------------------------
1534 -- Store_Encoded_Character --
1535 -----------------------------
1537 procedure Store_Encoded_Character (C : Char_Code) is
1539 Append_Encoded (Global_Name_Buffer, C);
1540 end Store_Encoded_Character;
1542 --------------------------------------
1543 -- Strip_Qualification_And_Suffixes --
1544 --------------------------------------
1546 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is
1550 -- Strip package body qualification string off end
1552 for J in reverse 2 .. Buf.Length loop
1553 if Buf.Chars (J) = 'X' then
1554 Buf.Length := J - 1;
1558 exit when Buf.Chars (J) /= 'b'
1559 and then Buf.Chars (J) /= 'n'
1560 and then Buf.Chars (J) /= 'p';
1563 -- Find rightmost __ or $ separator if one exists. First we position
1564 -- to start the search. If we have a character constant, position
1565 -- just before it, otherwise position to last character but one
1567 if Buf.Chars (Buf.Length) = ''' then
1568 J := Buf.Length - 2;
1569 while J > 0 and then Buf.Chars (J) /= ''' loop
1574 J := Buf.Length - 1;
1577 -- Loop to search for rightmost __ or $ (homonym) separator
1581 -- If $ separator, homonym separator, so strip it and keep looking
1583 if Buf.Chars (J) = '$' then
1584 Buf.Length := J - 1;
1585 J := Buf.Length - 1;
1587 -- Else check for __ found
1589 elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then
1591 -- Found __ so see if digit follows, and if so, this is a
1592 -- homonym separator, so strip it and keep looking.
1594 if Buf.Chars (J + 2) in '0' .. '9' then
1595 Buf.Length := J - 1;
1596 J := Buf.Length - 1;
1598 -- If not a homonym separator, then we simply strip the
1599 -- separator and everything that precedes it, and we are done
1602 Buf.Chars (1 .. Buf.Length - J - 1) :=
1603 Buf.Chars (J + 2 .. Buf.Length);
1604 Buf.Length := Buf.Length - J - 1;
1612 end Strip_Qualification_And_Suffixes;
1618 function To_String (X : Bounded_String) return String is
1620 return X.Chars (1 .. X.Length);
1627 procedure Tree_Read is
1629 Name_Chars.Tree_Read;
1630 Name_Entries.Tree_Read;
1633 (Hash_Table'Address,
1634 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1641 procedure Tree_Write is
1643 Name_Chars.Tree_Write;
1644 Name_Entries.Tree_Write;
1647 (Hash_Table'Address,
1648 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1657 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1658 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1659 Name_Chars.Locked := False;
1660 Name_Entries.Locked := False;
1662 Name_Entries.Release;
1669 procedure wn (Id : Name_Id) is
1671 if Id not in Name_Entries.First .. Name_Entries.Last then
1672 Write_Str ("<invalid name_id>");
1674 elsif Id = No_Name then
1675 Write_Str ("<No_Name>");
1677 elsif Id = Error_Name then
1678 Write_Str ("<Error_Name>");
1682 Buf : Bounded_String;
1685 Write_Str (Buf.Chars (1 .. Buf.Length));
1696 procedure Write_Name (Id : Name_Id) is
1697 Buf : Bounded_String;
1699 if Id >= First_Name_Id then
1701 Write_Str (Buf.Chars (1 .. Buf.Length));
1705 ------------------------
1706 -- Write_Name_Decoded --
1707 ------------------------
1709 procedure Write_Name_Decoded (Id : Name_Id) is
1710 Buf : Bounded_String;
1712 if Id >= First_Name_Id then
1713 Append_Decoded (Buf, Id);
1714 Write_Str (Buf.Chars (1 .. Buf.Length));
1716 end Write_Name_Decoded;
1718 -- Package initialization, initialize tables