1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 System; use System;
40 with Tree_IO; use Tree_IO;
43 with Interfaces; use Interfaces;
47 Name_Chars_Reserve : constant := 5000;
48 Name_Entries_Reserve : constant := 100;
49 -- The names table is locked during gigi processing, since gigi assumes
50 -- that the table does not move. After returning from gigi, the names
51 -- table is unlocked again, since writing library file information needs
52 -- to generate some extra names. To avoid the inefficiency of always
53 -- reallocating during this second unlocked phase, we reserve a bit of
54 -- extra space before doing the release call.
56 Hash_Num : constant Int := 2**16;
57 -- Number of headers in the hash table. Current hash algorithm is closely
58 -- tailored to this choice, so it can only be changed if a corresponding
59 -- change is made to the hash algorithm.
61 Hash_Max : constant Int := Hash_Num - 1;
62 -- Indexes in the hash header table run from 0 to Hash_Num - 1
64 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
65 -- Range of hash index values
67 Hash_Table : array (Hash_Index_Type) of Name_Id;
68 -- The hash table is used to locate existing entries in the names table.
69 -- The entries point to the first names table entry whose hash value
70 -- matches the hash code. Then subsequent names table entries with the
71 -- same hash code value are linked through the Hash_Link fields.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Hash (Buf : Bounded_String) return Hash_Index_Type;
79 -- Compute hash code for name stored in Buf
81 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String);
82 -- Given an encoded entity name in Buf, remove package body
83 -- suffix as described for Strip_Package_Body_Suffix, and also remove
84 -- all qualification, i.e. names followed by two underscores.
86 -----------------------------
87 -- Add_Char_To_Name_Buffer --
88 -----------------------------
90 procedure Add_Char_To_Name_Buffer (C : Character) is
92 Append (Global_Name_Buffer, C);
93 end Add_Char_To_Name_Buffer;
95 ----------------------------
96 -- Add_Nat_To_Name_Buffer --
97 ----------------------------
99 procedure Add_Nat_To_Name_Buffer (V : Nat) is
101 Append (Global_Name_Buffer, V);
102 end Add_Nat_To_Name_Buffer;
104 ----------------------------
105 -- Add_Str_To_Name_Buffer --
106 ----------------------------
108 procedure Add_Str_To_Name_Buffer (S : String) is
110 Append (Global_Name_Buffer, S);
111 end Add_Str_To_Name_Buffer;
117 procedure Append (Buf : in out Bounded_String; C : Character) is
119 Buf.Length := Buf.Length + 1;
121 if Buf.Length > Buf.Chars'Last then
122 Write_Str ("Name buffer overflow; Max_Length = ");
123 Write_Int (Int (Buf.Max_Length));
128 Buf.Chars (Buf.Length) := C;
131 procedure Append (Buf : in out Bounded_String; V : Nat) is
134 Append (Buf, V / 10);
137 Append (Buf, Character'Val (Character'Pos ('0') + V rem 10));
140 procedure Append (Buf : in out Bounded_String; S : String) is
141 First : constant Natural := Buf.Length + 1;
143 Buf.Length := Buf.Length + S'Length;
145 if Buf.Length > Buf.Chars'Last then
146 Write_Str ("Name buffer overflow; Max_Length = ");
147 Write_Int (Int (Buf.Max_Length));
152 Buf.Chars (First .. Buf.Length) := S;
153 -- A loop calling Append(Character) would be cleaner, but this slice
154 -- assignment is substantially faster.
157 procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is
159 Append (Buf, Buf2.Chars (1 .. Buf2.Length));
162 procedure Append (Buf : in out Bounded_String; Id : Valid_Name_Id) is
163 pragma Assert (Is_Valid_Name (Id));
165 Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
166 Len : constant Short := Name_Entries.Table (Id).Name_Len;
167 Chars : Name_Chars.Table_Type renames
168 Name_Chars.Table (Index + 1 .. Index + Int (Len));
170 Append (Buf, String (Chars));
177 procedure Append_Decoded
178 (Buf : in out Bounded_String;
183 Temp : Bounded_String;
188 -- Skip scan if we already know there are no encodings
190 if Name_Entries.Table (Id).Name_Has_No_Encodings then
194 -- Quick loop to see if there is anything special to do
198 if P = Temp.Length then
199 Name_Entries.Table (Id).Name_Has_No_Encodings := True;
215 -- Here we have at least some encoding that we must decode
220 New_Buf : String (1 .. Temp.Chars'Last);
222 procedure Copy_One_Character;
223 -- Copy a character from Temp.Chars to New_Buf. Includes case
224 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
226 function Hex (N : Natural) return Word;
227 -- Scans past N digits using Old pointer and returns hex value
229 procedure Insert_Character (C : Character);
230 -- Insert a new character into output decoded name
232 ------------------------
233 -- Copy_One_Character --
234 ------------------------
236 procedure Copy_One_Character is
240 C := Temp.Chars (Old);
242 -- U (upper half insertion case)
245 and then Old < Temp.Length
246 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
247 and then Temp.Chars (Old + 1) /= '_'
251 -- If we have upper half encoding, then we have to set an
252 -- appropriate wide character sequence for this character.
254 if Upper_Half_Encoding then
255 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
257 -- For other encoding methods, upper half characters can
258 -- simply use their normal representation.
262 W2 : constant Word := Hex (2);
264 pragma Assert (W2 <= 255);
265 -- Add assumption to facilitate static analysis. Note
266 -- that we cannot use pragma Assume for bootstrap
268 Insert_Character (Character'Val (W2));
272 -- WW (wide wide character insertion)
275 and then Old < Temp.Length
276 and then Temp.Chars (Old + 1) = 'W'
279 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
281 -- W (wide character insertion)
284 and then Old < Temp.Length
285 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
286 and then Temp.Chars (Old + 1) /= '_'
289 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
291 -- Any other character is copied unchanged
294 Insert_Character (C);
297 end Copy_One_Character;
303 function Hex (N : Natural) return Word is
309 C := Temp.Chars (Old);
312 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
315 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
316 else -- C in 'a' .. 'f'
317 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
324 ----------------------
325 -- Insert_Character --
326 ----------------------
328 procedure Insert_Character (C : Character) is
330 New_Len := New_Len + 1;
331 New_Buf (New_Len) := C;
332 end Insert_Character;
334 -- Start of processing for Decode
340 -- Loop through characters of name
342 while Old <= Temp.Length loop
344 -- Case of character literal, put apostrophes around character
346 if Temp.Chars (Old) = 'Q'
347 and then Old < Temp.Length
350 Insert_Character (''');
352 Insert_Character (''');
354 -- Case of operator name
356 elsif Temp.Chars (Old) = 'O'
357 and then Old < Temp.Length
358 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
359 and then Temp.Chars (Old + 1) /= '_'
364 -- This table maps the 2nd and 3rd characters of the name
365 -- into the required output. Two blanks means leave the
368 Map : constant String :=
369 "ab " & -- Oabs => "abs"
370 "ad+ " & -- Oadd => "+"
371 "an " & -- Oand => "and"
372 "co& " & -- Oconcat => "&"
373 "di/ " & -- Odivide => "/"
374 "eq= " & -- Oeq => "="
375 "ex**" & -- Oexpon => "**"
376 "gt> " & -- Ogt => ">"
377 "ge>=" & -- Oge => ">="
378 "le<=" & -- Ole => "<="
379 "lt< " & -- Olt => "<"
380 "mo " & -- Omod => "mod"
381 "mu* " & -- Omutliply => "*"
382 "ne/=" & -- One => "/="
383 "no " & -- Onot => "not"
384 "or " & -- Oor => "or"
385 "re " & -- Orem => "rem"
386 "su- " & -- Osubtract => "-"
387 "xo "; -- Oxor => "xor"
392 Insert_Character ('"');
394 -- Search the map. Note that this loop must terminate, if
395 -- not we have some kind of internal error, and a constraint
396 -- error may be raised.
400 exit when Temp.Chars (Old) = Map (J)
401 and then Temp.Chars (Old + 1) = Map (J + 1);
405 -- Special operator name
407 if Map (J + 2) /= ' ' then
408 Insert_Character (Map (J + 2));
410 if Map (J + 3) /= ' ' then
411 Insert_Character (Map (J + 3));
414 Insert_Character ('"');
416 -- Skip past original operator name in input
418 while Old <= Temp.Length
419 and then Temp.Chars (Old) in 'a' .. 'z'
424 -- For other operator names, leave them in lower case,
425 -- surrounded by apostrophes
428 -- Copy original operator name from input to output
430 while Old <= Temp.Length
431 and then Temp.Chars (Old) in 'a' .. 'z'
436 Insert_Character ('"');
440 -- Else copy one character and keep going
447 -- Copy new buffer as result
449 Temp.Length := New_Len;
450 Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
457 ----------------------------------
458 -- Append_Decoded_With_Brackets --
459 ----------------------------------
461 procedure Append_Decoded_With_Brackets
462 (Buf : in out Bounded_String;
468 -- Case of operator name, normal decoding is fine
470 if Buf.Chars (1) = 'O' then
471 Append_Decoded (Buf, Id);
473 -- For character literals, normal decoding is fine
475 elsif Buf.Chars (1) = 'Q' then
476 Append_Decoded (Buf, Id);
478 -- Only remaining issue is U/W/WW sequences
482 Temp : Bounded_String;
487 while P < Temp.Length loop
488 if Temp.Chars (P + 1) in 'A' .. 'Z' then
493 elsif Temp.Chars (P) = 'U' then
494 for J in reverse P + 3 .. P + Temp.Length loop
495 Temp.Chars (J + 3) := Temp.Chars (J);
498 Temp.Length := Temp.Length + 3;
499 Temp.Chars (P + 3) := Temp.Chars (P + 2);
500 Temp.Chars (P + 2) := Temp.Chars (P + 1);
501 Temp.Chars (P) := '[';
502 Temp.Chars (P + 1) := '"';
503 Temp.Chars (P + 4) := '"';
504 Temp.Chars (P + 5) := ']';
507 -- WWhhhhhhhh encoding
509 elsif Temp.Chars (P) = 'W'
510 and then P + 9 <= Temp.Length
511 and then Temp.Chars (P + 1) = 'W'
512 and then Temp.Chars (P + 2) not in 'A' .. 'Z'
513 and then Temp.Chars (P + 2) /= '_'
515 Temp.Chars (P + 12 .. Temp.Length + 2) :=
516 Temp.Chars (P + 10 .. Temp.Length);
517 Temp.Chars (P) := '[';
518 Temp.Chars (P + 1) := '"';
519 Temp.Chars (P + 10) := '"';
520 Temp.Chars (P + 11) := ']';
521 Temp.Length := Temp.Length + 2;
526 elsif Temp.Chars (P) = 'W'
527 and then P < Temp.Length
528 and then Temp.Chars (P + 1) not in 'A' .. 'Z'
529 and then Temp.Chars (P + 1) /= '_'
531 Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
532 Temp.Chars (P + 5 .. Temp.Length);
533 Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4);
534 Temp.Chars (P) := '[';
535 Temp.Chars (P + 1) := '"';
536 Temp.Chars (P + 6) := '"';
537 Temp.Chars (P + 7) := ']';
538 Temp.Length := Temp.Length + 3;
549 end Append_Decoded_With_Brackets;
555 procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is
556 procedure Set_Hex_Chars (C : Char_Code);
557 -- Stores given value, which is in the range 0 .. 255, as two hex
558 -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length.
564 procedure Set_Hex_Chars (C : Char_Code) is
565 Hexd : constant String := "0123456789abcdef";
566 N : constant Natural := Natural (C);
568 Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1);
569 Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1);
570 Buf.Length := Buf.Length + 2;
573 -- Start of processing for Append_Encoded
576 Buf.Length := Buf.Length + 1;
578 if In_Character_Range (C) then
580 CC : constant Character := Get_Character (C);
582 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
583 Buf.Chars (Buf.Length) := CC;
585 Buf.Chars (Buf.Length) := 'U';
590 elsif In_Wide_Character_Range (C) then
591 Buf.Chars (Buf.Length) := 'W';
592 Set_Hex_Chars (C / 256);
593 Set_Hex_Chars (C mod 256);
596 Buf.Chars (Buf.Length) := 'W';
597 Buf.Length := Buf.Length + 1;
598 Buf.Chars (Buf.Length) := 'W';
599 Set_Hex_Chars (C / 2 ** 24);
600 Set_Hex_Chars ((C / 2 ** 16) mod 256);
601 Set_Hex_Chars ((C / 256) mod 256);
602 Set_Hex_Chars (C mod 256);
606 ------------------------
607 -- Append_Unqualified --
608 ------------------------
610 procedure Append_Unqualified
611 (Buf : in out Bounded_String;
614 Temp : Bounded_String;
617 Strip_Qualification_And_Suffixes (Temp);
619 end Append_Unqualified;
621 --------------------------------
622 -- Append_Unqualified_Decoded --
623 --------------------------------
625 procedure Append_Unqualified_Decoded
626 (Buf : in out Bounded_String;
629 Temp : Bounded_String;
631 Append_Decoded (Temp, Id);
632 Strip_Qualification_And_Suffixes (Temp);
634 end Append_Unqualified_Decoded;
640 procedure Finalize is
641 F : array (Int range 0 .. 50) of Int;
642 -- N'th entry is the number of chains of length N, except last entry,
643 -- which is the number of chains of length F'Last or more.
645 Max_Chain_Length : Nat := 0;
646 -- Maximum length of all chains
649 -- Used to compute average number of probes
652 -- Number of symbols in table
654 Verbosity : constant Int range 1 .. 3 := 1;
655 pragma Warnings (Off, Verbosity);
656 -- This constant indicates the level of verbosity in the output from
657 -- this procedure. Currently this can only be changed by editing the
658 -- declaration above and recompiling. That's good enough in practice,
659 -- since we very rarely need to use this debug option. Settings are:
661 -- 1 => print basic summary information
662 -- 2 => in addition print number of entries per hash chain
663 -- 3 => in addition print content of entries
665 Zero : constant Int := Character'Pos ('0');
668 if not Debug_Flag_H then
672 for J in F'Range loop
676 for J in Hash_Index_Type loop
677 if Hash_Table (J) = No_Name then
690 while N /= No_Name loop
691 N := Name_Entries.Table (N).Hash_Link;
696 Probes := Probes + (1 + C) * 100;
698 if C > Max_Chain_Length then
699 Max_Chain_Length := C;
702 if Verbosity >= 2 then
703 Write_Str ("Hash_Table (");
705 Write_Str (") has ");
707 Write_Str (" entries");
714 F (F'Last) := F (F'Last) + 1;
717 if Verbosity >= 3 then
719 while N /= No_Name loop
720 S := Name_Entries.Table (N).Name_Chars_Index;
724 for J in 1 .. Name_Entries.Table (N).Name_Len loop
725 Write_Char (Name_Chars.Table (S + Int (J)));
730 N := Name_Entries.Table (N).Hash_Link;
739 for J in F'Range loop
741 Write_Str ("Number of hash chains of length ");
750 Write_Str (" or greater");
759 -- Print out average number of probes, in the case where Name_Find is
760 -- called for a string that is already in the table.
763 Write_Str ("Average number of probes for lookup = ");
764 pragma Assert (Nsyms /= 0);
765 -- Add assumption to facilitate static analysis. Here Nsyms cannot be
766 -- zero because many symbols are added to the table by default.
767 Probes := Probes / Nsyms;
768 Write_Int (Probes / 200);
770 Probes := (Probes mod 200) / 2;
771 Write_Char (Character'Val (Zero + Probes / 10));
772 Write_Char (Character'Val (Zero + Probes mod 10));
775 Write_Str ("Max_Chain_Length = ");
776 Write_Int (Max_Chain_Length);
778 Write_Str ("Name_Chars'Length = ");
779 Write_Int (Name_Chars.Last - Name_Chars.First + 1);
781 Write_Str ("Name_Entries'Length = ");
782 Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
784 Write_Str ("Nsyms = ");
789 -----------------------------
790 -- Get_Decoded_Name_String --
791 -----------------------------
793 procedure Get_Decoded_Name_String (Id : Valid_Name_Id) is
795 Global_Name_Buffer.Length := 0;
796 Append_Decoded (Global_Name_Buffer, Id);
797 end Get_Decoded_Name_String;
799 -------------------------------------------
800 -- Get_Decoded_Name_String_With_Brackets --
801 -------------------------------------------
803 procedure Get_Decoded_Name_String_With_Brackets (Id : Valid_Name_Id) is
805 Global_Name_Buffer.Length := 0;
806 Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
807 end Get_Decoded_Name_String_With_Brackets;
809 ------------------------
810 -- Get_Last_Two_Chars --
811 ------------------------
813 procedure Get_Last_Two_Chars
818 NE : Name_Entry renames Name_Entries.Table (N);
819 NEL : constant Int := Int (NE.Name_Len);
823 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
824 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
829 end Get_Last_Two_Chars;
831 ---------------------
832 -- Get_Name_String --
833 ---------------------
835 procedure Get_Name_String (Id : Valid_Name_Id) is
837 Global_Name_Buffer.Length := 0;
838 Append (Global_Name_Buffer, Id);
841 function Get_Name_String (Id : Valid_Name_Id) return String is
842 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
848 --------------------------------
849 -- Get_Name_String_And_Append --
850 --------------------------------
852 procedure Get_Name_String_And_Append (Id : Valid_Name_Id) is
854 Append (Global_Name_Buffer, Id);
855 end Get_Name_String_And_Append;
857 -----------------------------
858 -- Get_Name_Table_Boolean1 --
859 -----------------------------
861 function Get_Name_Table_Boolean1 (Id : Valid_Name_Id) return Boolean is
863 pragma Assert (Is_Valid_Name (Id));
864 return Name_Entries.Table (Id).Boolean1_Info;
865 end Get_Name_Table_Boolean1;
867 -----------------------------
868 -- Get_Name_Table_Boolean2 --
869 -----------------------------
871 function Get_Name_Table_Boolean2 (Id : Valid_Name_Id) return Boolean is
873 pragma Assert (Is_Valid_Name (Id));
874 return Name_Entries.Table (Id).Boolean2_Info;
875 end Get_Name_Table_Boolean2;
877 -----------------------------
878 -- Get_Name_Table_Boolean3 --
879 -----------------------------
881 function Get_Name_Table_Boolean3 (Id : Valid_Name_Id) return Boolean is
883 pragma Assert (Is_Valid_Name (Id));
884 return Name_Entries.Table (Id).Boolean3_Info;
885 end Get_Name_Table_Boolean3;
887 -------------------------
888 -- Get_Name_Table_Byte --
889 -------------------------
891 function Get_Name_Table_Byte (Id : Valid_Name_Id) return Byte is
893 pragma Assert (Is_Valid_Name (Id));
894 return Name_Entries.Table (Id).Byte_Info;
895 end Get_Name_Table_Byte;
897 -------------------------
898 -- Get_Name_Table_Int --
899 -------------------------
901 function Get_Name_Table_Int (Id : Valid_Name_Id) return Int is
903 pragma Assert (Is_Valid_Name (Id));
904 return Name_Entries.Table (Id).Int_Info;
905 end Get_Name_Table_Int;
907 -----------------------------------------
908 -- Get_Unqualified_Decoded_Name_String --
909 -----------------------------------------
911 procedure Get_Unqualified_Decoded_Name_String (Id : Valid_Name_Id) is
913 Global_Name_Buffer.Length := 0;
914 Append_Unqualified_Decoded (Global_Name_Buffer, Id);
915 end Get_Unqualified_Decoded_Name_String;
917 ---------------------------------
918 -- Get_Unqualified_Name_String --
919 ---------------------------------
921 procedure Get_Unqualified_Name_String (Id : Valid_Name_Id) is
923 Global_Name_Buffer.Length := 0;
924 Append_Unqualified (Global_Name_Buffer, Id);
925 end Get_Unqualified_Name_String;
931 function Hash (Buf : Bounded_String) return Hash_Index_Type is
933 -- This hash function looks at every character, in order to make it
934 -- likely that similar strings get different hash values. The rotate by
935 -- 7 bits has been determined empirically to be good, and it doesn't
936 -- lose bits like a shift would. The final conversion can't overflow,
937 -- because the table is 2**16 in size. This function probably needs to
938 -- be changed if the hash table size is changed.
940 -- Note that we could get some speed improvement by aligning the string
941 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement
942 -- a growable table. It doesn't seem worth the trouble to do those
945 Result : Unsigned_16 := 0;
948 for J in 1 .. Buf.Length loop
949 Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J));
952 return Hash_Index_Type (Result);
959 procedure Initialize is
969 (Buf : in out Bounded_String;
973 SL : constant Natural := S'Length;
976 Buf.Chars (Index + SL .. Buf.Length + SL) :=
977 Buf.Chars (Index .. Buf.Length);
978 Buf.Chars (Index .. Index + SL - 1) := S;
979 Buf.Length := Buf.Length + SL;
982 -------------------------------
983 -- Insert_Str_In_Name_Buffer --
984 -------------------------------
986 procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
988 Insert_Str (Global_Name_Buffer, S, Index);
989 end Insert_Str_In_Name_Buffer;
991 ----------------------
992 -- Is_Internal_Name --
993 ----------------------
995 function Is_Internal_Name (Buf : Bounded_String) return Boolean is
999 -- Any name starting or ending with underscore is internal
1001 if Buf.Chars (1) = '_'
1002 or else Buf.Chars (Buf.Length) = '_'
1006 -- Allow quoted character
1008 elsif Buf.Chars (1) = ''' then
1011 -- All other cases, scan name
1014 -- Test backwards, because we only want to test the last entity
1015 -- name if the name we have is qualified with other entities.
1020 -- Skip stuff between brackets (A-F OK there)
1022 if Buf.Chars (J) = ']' then
1025 exit when J = 1 or else Buf.Chars (J) = '[';
1028 -- Test for internal letter
1030 elsif Is_OK_Internal_Letter (Buf.Chars (J)) then
1033 -- Quit if we come to terminating double underscore (note that
1034 -- if the current character is an underscore, we know that
1035 -- there is a previous character present, since we already
1036 -- filtered out the case of Buf.Chars (1) = '_' above.
1038 elsif Buf.Chars (J) = '_'
1039 and then Buf.Chars (J - 1) = '_'
1040 and then Buf.Chars (J - 2) /= '_'
1050 end Is_Internal_Name;
1052 function Is_Internal_Name (Id : Valid_Name_Id) return Boolean is
1053 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
1056 return Is_Internal_Name (Buf);
1057 end Is_Internal_Name;
1059 function Is_Internal_Name return Boolean is
1061 return Is_Internal_Name (Global_Name_Buffer);
1062 end Is_Internal_Name;
1064 ---------------------------
1065 -- Is_OK_Internal_Letter --
1066 ---------------------------
1068 function Is_OK_Internal_Letter (C : Character) return Boolean is
1070 return C in 'A' .. 'Z'
1076 end Is_OK_Internal_Letter;
1078 ----------------------
1079 -- Is_Operator_Name --
1080 ----------------------
1082 function Is_Operator_Name (Id : Valid_Name_Id) return Boolean is
1085 pragma Assert (Is_Valid_Name (Id));
1086 S := Name_Entries.Table (Id).Name_Chars_Index;
1087 return Name_Chars.Table (S + 1) = 'O';
1088 end Is_Operator_Name;
1094 function Is_Valid_Name (Id : Name_Id) return Boolean is
1096 return Id in Name_Entries.First .. Name_Entries.Last;
1099 --------------------
1100 -- Length_Of_Name --
1101 --------------------
1103 function Length_Of_Name (Id : Valid_Name_Id) return Nat is
1105 return Int (Name_Entries.Table (Id).Name_Len);
1114 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
1115 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
1117 Name_Chars.Locked := True;
1118 Name_Entries.Release;
1119 Name_Entries.Locked := True;
1127 (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id
1131 ((Name_Chars_Index => Name_Chars.Last,
1132 Name_Len => Short (Buf.Length),
1135 Boolean1_Info => False,
1136 Boolean2_Info => False,
1137 Boolean3_Info => False,
1138 Name_Has_No_Encodings => False,
1139 Hash_Link => No_Name));
1141 -- Set corresponding string entry in the Name_Chars table
1143 for J in 1 .. Buf.Length loop
1144 Name_Chars.Append (Buf.Chars (J));
1147 Name_Chars.Append (ASCII.NUL);
1149 return Name_Entries.Last;
1152 function Name_Enter (S : String) return Valid_Name_Id is
1153 Buf : Bounded_String (Max_Length => S'Length);
1156 return Name_Enter (Buf);
1159 ------------------------
1160 -- Name_Entries_Count --
1161 ------------------------
1163 function Name_Entries_Count return Nat is
1165 return Int (Name_Entries.Last - Name_Entries.First + 1);
1166 end Name_Entries_Count;
1173 (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id
1176 -- Id of entry in hash search, and value to be returned
1179 -- Pointer into string table
1181 Hash_Index : Hash_Index_Type;
1182 -- Computed hash index
1185 -- Quick handling for one character names
1187 if Buf.Length = 1 then
1188 return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
1190 -- Otherwise search hash table for existing matching entry
1193 Hash_Index := Namet.Hash (Buf);
1194 New_Id := Hash_Table (Hash_Index);
1196 if New_Id = No_Name then
1197 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1202 Integer (Name_Entries.Table (New_Id).Name_Len)
1207 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1209 for J in 1 .. Buf.Length loop
1210 if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then
1217 -- Current entry in hash chain does not match
1220 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1221 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1223 Name_Entries.Table (New_Id).Hash_Link :=
1224 Name_Entries.Last + 1;
1230 -- We fall through here only if a matching entry was not found in the
1231 -- hash table. We now create a new entry in the names table. The hash
1232 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1235 ((Name_Chars_Index => Name_Chars.Last,
1236 Name_Len => Short (Buf.Length),
1237 Hash_Link => No_Name,
1238 Name_Has_No_Encodings => False,
1241 Boolean1_Info => False,
1242 Boolean2_Info => False,
1243 Boolean3_Info => False));
1245 -- Set corresponding string entry in the Name_Chars table
1247 for J in 1 .. Buf.Length loop
1248 Name_Chars.Append (Buf.Chars (J));
1251 Name_Chars.Append (ASCII.NUL);
1253 return Name_Entries.Last;
1257 function Name_Find (S : String) return Valid_Name_Id is
1258 Buf : Bounded_String (Max_Length => S'Length);
1261 return Name_Find (Buf);
1271 V2 : Name_Id) return Boolean
1274 return T = V1 or else
1282 V3 : Name_Id) return Boolean
1285 return T = V1 or else
1295 V4 : Name_Id) return Boolean
1298 return T = V1 or else
1310 V5 : Name_Id) return Boolean
1313 return T = V1 or else
1327 V6 : Name_Id) return Boolean
1330 return T = V1 or else
1346 V7 : Name_Id) return Boolean
1349 return T = V1 or else
1367 V8 : Name_Id) return Boolean
1370 return T = V1 or else
1390 V9 : Name_Id) return Boolean
1393 return T = V1 or else
1415 V10 : Name_Id) return Boolean
1418 return T = V1 or else
1442 V11 : Name_Id) return Boolean
1445 return T = V1 or else
1471 V12 : Name_Id) return Boolean
1474 return T = V1 or else
1492 function Name_Equals
1493 (N1 : Valid_Name_Id;
1494 N2 : Valid_Name_Id) return Boolean
1497 return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
1504 function Present (Nam : File_Name_Type) return Boolean is
1506 return Nam /= No_File;
1513 function Present (Nam : Name_Id) return Boolean is
1515 return Nam /= No_Name;
1522 function Present (Nam : Unit_Name_Type) return Boolean is
1524 return Nam /= No_Unit_Name;
1531 procedure Reinitialize is
1536 -- Initialize entries for one character names
1538 for C in Character loop
1540 ((Name_Chars_Index => Name_Chars.Last,
1544 Boolean1_Info => False,
1545 Boolean2_Info => False,
1546 Boolean3_Info => False,
1547 Name_Has_No_Encodings => True,
1548 Hash_Link => No_Name));
1550 Name_Chars.Append (C);
1551 Name_Chars.Append (ASCII.NUL);
1556 for J in Hash_Index_Type loop
1557 Hash_Table (J) := No_Name;
1561 ----------------------
1562 -- Reset_Name_Table --
1563 ----------------------
1565 procedure Reset_Name_Table is
1567 for J in First_Name_Id .. Name_Entries.Last loop
1568 Name_Entries.Table (J).Int_Info := 0;
1569 Name_Entries.Table (J).Byte_Info := 0;
1571 end Reset_Name_Table;
1573 --------------------------------
1574 -- Set_Character_Literal_Name --
1575 --------------------------------
1577 procedure Set_Character_Literal_Name
1578 (Buf : in out Bounded_String;
1584 Append_Encoded (Buf, C);
1585 end Set_Character_Literal_Name;
1587 procedure Set_Character_Literal_Name (C : Char_Code) is
1589 Set_Character_Literal_Name (Global_Name_Buffer, C);
1590 end Set_Character_Literal_Name;
1592 -----------------------------
1593 -- Set_Name_Table_Boolean1 --
1594 -----------------------------
1596 procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean) is
1598 pragma Assert (Is_Valid_Name (Id));
1599 Name_Entries.Table (Id).Boolean1_Info := Val;
1600 end Set_Name_Table_Boolean1;
1602 -----------------------------
1603 -- Set_Name_Table_Boolean2 --
1604 -----------------------------
1606 procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean) is
1608 pragma Assert (Is_Valid_Name (Id));
1609 Name_Entries.Table (Id).Boolean2_Info := Val;
1610 end Set_Name_Table_Boolean2;
1612 -----------------------------
1613 -- Set_Name_Table_Boolean3 --
1614 -----------------------------
1616 procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean) is
1618 pragma Assert (Is_Valid_Name (Id));
1619 Name_Entries.Table (Id).Boolean3_Info := Val;
1620 end Set_Name_Table_Boolean3;
1622 -------------------------
1623 -- Set_Name_Table_Byte --
1624 -------------------------
1626 procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte) is
1628 pragma Assert (Is_Valid_Name (Id));
1629 Name_Entries.Table (Id).Byte_Info := Val;
1630 end Set_Name_Table_Byte;
1632 -------------------------
1633 -- Set_Name_Table_Int --
1634 -------------------------
1636 procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int) is
1638 pragma Assert (Is_Valid_Name (Id));
1639 Name_Entries.Table (Id).Int_Info := Val;
1640 end Set_Name_Table_Int;
1642 -----------------------------
1643 -- Store_Encoded_Character --
1644 -----------------------------
1646 procedure Store_Encoded_Character (C : Char_Code) is
1648 Append_Encoded (Global_Name_Buffer, C);
1649 end Store_Encoded_Character;
1651 --------------------------------------
1652 -- Strip_Qualification_And_Suffixes --
1653 --------------------------------------
1655 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is
1659 -- Strip package body qualification string off end
1661 for J in reverse 2 .. Buf.Length loop
1662 if Buf.Chars (J) = 'X' then
1663 Buf.Length := J - 1;
1667 exit when Buf.Chars (J) /= 'b'
1668 and then Buf.Chars (J) /= 'n'
1669 and then Buf.Chars (J) /= 'p';
1672 -- Find rightmost __ or $ separator if one exists. First we position
1673 -- to start the search. If we have a character constant, position
1674 -- just before it, otherwise position to last character but one
1676 if Buf.Chars (Buf.Length) = ''' then
1677 J := Buf.Length - 2;
1678 while J > 0 and then Buf.Chars (J) /= ''' loop
1683 J := Buf.Length - 1;
1686 -- Loop to search for rightmost __ or $ (homonym) separator
1690 -- If $ separator, homonym separator, so strip it and keep looking
1692 if Buf.Chars (J) = '$' then
1693 Buf.Length := J - 1;
1694 J := Buf.Length - 1;
1696 -- Else check for __ found
1698 elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then
1700 -- Found __ so see if digit follows, and if so, this is a
1701 -- homonym separator, so strip it and keep looking.
1703 if Buf.Chars (J + 2) in '0' .. '9' then
1704 Buf.Length := J - 1;
1705 J := Buf.Length - 1;
1707 -- If not a homonym separator, then we simply strip the
1708 -- separator and everything that precedes it, and we are done
1711 Buf.Chars (1 .. Buf.Length - J - 1) :=
1712 Buf.Chars (J + 2 .. Buf.Length);
1713 Buf.Length := Buf.Length - J - 1;
1721 end Strip_Qualification_And_Suffixes;
1727 function To_String (Buf : Bounded_String) return String is
1729 return Buf.Chars (1 .. Buf.Length);
1736 procedure Tree_Read is
1738 Name_Chars.Tree_Read;
1739 Name_Entries.Tree_Read;
1742 (Hash_Table'Address,
1743 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1750 procedure Tree_Write is
1752 Name_Chars.Tree_Write;
1753 Name_Entries.Tree_Write;
1756 (Hash_Table'Address,
1757 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1766 Name_Chars.Locked := False;
1767 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1769 Name_Entries.Locked := False;
1770 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1771 Name_Entries.Release;
1778 procedure wn (Id : Name_Id) is
1780 if Is_Valid_Name (Id) then
1782 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
1785 Write_Str (Buf.Chars (1 .. Buf.Length));
1788 elsif Id = No_Name then
1789 Write_Str ("<No_Name>");
1791 elsif Id = Error_Name then
1792 Write_Str ("<Error_Name>");
1795 Write_Str ("<invalid name_id>");
1796 Write_Int (Int (Id));
1806 procedure Write_Name (Id : Valid_Name_Id) is
1807 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
1810 Write_Str (Buf.Chars (1 .. Buf.Length));
1813 ------------------------
1814 -- Write_Name_Decoded --
1815 ------------------------
1817 procedure Write_Name_Decoded (Id : Valid_Name_Id) is
1818 Buf : Bounded_String;
1820 Append_Decoded (Buf, Id);
1821 Write_Str (Buf.Chars (1 .. Buf.Length));
1822 end Write_Name_Decoded;
1824 -- Package initialization, initialize tables