1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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;
44 Name_Chars_Reserve : constant := 5000;
45 Name_Entries_Reserve : constant := 100;
46 -- The names table is locked during gigi processing, since gigi assumes
47 -- that the table does not move. After returning from gigi, the names
48 -- table is unlocked again, since writing library file information needs
49 -- to generate some extra names. To avoid the inefficiency of always
50 -- reallocating during this second unlocked phase, we reserve a bit of
51 -- extra space before doing the release call.
53 Hash_Num : constant Int := 2**12;
54 -- Number of headers in the hash table. Current hash algorithm is closely
55 -- tailored to this choice, so it can only be changed if a corresponding
56 -- change is made to the hash algorithm.
58 Hash_Max : constant Int := Hash_Num - 1;
59 -- Indexes in the hash header table run from 0 to Hash_Num - 1
61 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
62 -- Range of hash index values
64 Hash_Table : array (Hash_Index_Type) of Name_Id;
65 -- The hash table is used to locate existing entries in the names table.
66 -- The entries point to the first names table entry whose hash value
67 -- matches the hash code. Then subsequent names table entries with the
68 -- same hash code value are linked through the Hash_Link fields.
70 -----------------------
71 -- Local Subprograms --
72 -----------------------
74 function Hash return Hash_Index_Type;
76 -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
78 procedure Strip_Qualification_And_Suffixes;
79 -- Given an encoded entity name in Name_Buffer, remove package body
80 -- suffix as described for Strip_Package_Body_Suffix, and also remove
81 -- all qualification, i.e. names followed by two underscores. The
82 -- contents of Name_Buffer is modified by this call, and on return
83 -- Name_Buffer and Name_Len reflect the stripped name.
85 -----------------------------
86 -- Add_Char_To_Name_Buffer --
87 -----------------------------
89 procedure Add_Char_To_Name_Buffer (C : Character) is
91 if Name_Len < Name_Buffer'Last then
92 Name_Len := Name_Len + 1;
93 Name_Buffer (Name_Len) := C;
95 end Add_Char_To_Name_Buffer;
97 ----------------------------
98 -- Add_Nat_To_Name_Buffer --
99 ----------------------------
101 procedure Add_Nat_To_Name_Buffer (V : Nat) is
104 Add_Nat_To_Name_Buffer (V / 10);
107 Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
108 end Add_Nat_To_Name_Buffer;
110 ----------------------------
111 -- Add_Str_To_Name_Buffer --
112 ----------------------------
114 procedure Add_Str_To_Name_Buffer (S : String) is
116 for J in S'Range loop
117 Add_Char_To_Name_Buffer (S (J));
119 end Add_Str_To_Name_Buffer;
125 procedure Finalize is
126 Max_Chain_Length : constant := 50;
127 -- Max length of chains for which specific information is output
129 F : array (Int range 0 .. Max_Chain_Length) of Int;
130 -- N'th entry is number of chains of length N
133 -- Used to compute average number of probes
136 -- Number of symbols in table
140 for J in F'Range loop
144 for J in Hash_Index_Type loop
145 if Hash_Table (J) = No_Name then
149 Write_Str ("Hash_Table (");
151 Write_Str (") has ");
162 while N /= No_Name loop
163 N := Name_Entries.Table (N).Hash_Link;
168 Write_Str (" entries");
171 if C < Max_Chain_Length then
174 F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
179 while N /= No_Name loop
180 S := Name_Entries.Table (N).Name_Chars_Index;
183 for J in 1 .. Name_Entries.Table (N).Name_Len loop
184 Write_Char (Name_Chars.Table (S + Int (J)));
188 N := Name_Entries.Table (N).Hash_Link;
196 for J in Int range 0 .. Max_Chain_Length loop
198 Write_Str ("Number of hash chains of length ");
206 if J = Max_Chain_Length then
207 Write_Str (" or greater");
215 Nsyms := Nsyms + F (J);
216 Probes := Probes + F (J) * (1 + J) * 100;
222 Write_Str ("Average number of probes for lookup = ");
223 Probes := Probes / Nsyms;
224 Write_Int (Probes / 200);
226 Probes := (Probes mod 200) / 2;
227 Write_Char (Character'Val (48 + Probes / 10));
228 Write_Char (Character'Val (48 + Probes mod 10));
234 -----------------------------
235 -- Get_Decoded_Name_String --
236 -----------------------------
238 procedure Get_Decoded_Name_String (Id : Name_Id) is
243 Get_Name_String (Id);
245 -- Skip scan if we already know there are no encodings
247 if Name_Entries.Table (Id).Name_Has_No_Encodings then
251 -- Quick loop to see if there is anything special to do
256 Name_Entries.Table (Id).Name_Has_No_Encodings := True;
260 C := Name_Buffer (P);
272 -- Here we have at least some encoding that we must decode
277 New_Buf : String (1 .. Name_Buffer'Last);
279 procedure Copy_One_Character;
280 -- Copy a character from Name_Buffer to New_Buf. Includes case
281 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
283 function Hex (N : Natural) return Word;
284 -- Scans past N digits using Old pointer and returns hex value
286 procedure Insert_Character (C : Character);
287 -- Insert a new character into output decoded name
289 ------------------------
290 -- Copy_One_Character --
291 ------------------------
293 procedure Copy_One_Character is
297 C := Name_Buffer (Old);
299 -- U (upper half insertion case)
302 and then Old < Name_Len
303 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
304 and then Name_Buffer (Old + 1) /= '_'
308 -- If we have upper half encoding, then we have to set an
309 -- appropriate wide character sequence for this character.
311 if Upper_Half_Encoding then
312 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
314 -- For other encoding methods, upper half characters can
315 -- simply use their normal representation.
318 Insert_Character (Character'Val (Hex (2)));
321 -- WW (wide wide character insertion)
324 and then Old < Name_Len
325 and then Name_Buffer (Old + 1) = 'W'
328 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
330 -- W (wide character insertion)
333 and then Old < Name_Len
334 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
335 and then Name_Buffer (Old + 1) /= '_'
338 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
340 -- Any other character is copied unchanged
343 Insert_Character (C);
346 end Copy_One_Character;
352 function Hex (N : Natural) return Word is
358 C := Name_Buffer (Old);
361 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
364 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
365 else -- C in 'a' .. 'f'
366 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
373 ----------------------
374 -- Insert_Character --
375 ----------------------
377 procedure Insert_Character (C : Character) is
379 New_Len := New_Len + 1;
380 New_Buf (New_Len) := C;
381 end Insert_Character;
383 -- Start of processing for Decode
389 -- Loop through characters of name
391 while Old <= Name_Len loop
393 -- Case of character literal, put apostrophes around character
395 if Name_Buffer (Old) = 'Q'
396 and then Old < Name_Len
399 Insert_Character (''');
401 Insert_Character (''');
403 -- Case of operator name
405 elsif Name_Buffer (Old) = 'O'
406 and then Old < Name_Len
407 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
408 and then Name_Buffer (Old + 1) /= '_'
413 -- This table maps the 2nd and 3rd characters of the name
414 -- into the required output. Two blanks means leave the
417 Map : constant String :=
418 "ab " & -- Oabs => "abs"
419 "ad+ " & -- Oadd => "+"
420 "an " & -- Oand => "and"
421 "co& " & -- Oconcat => "&"
422 "di/ " & -- Odivide => "/"
423 "eq= " & -- Oeq => "="
424 "ex**" & -- Oexpon => "**"
425 "gt> " & -- Ogt => ">"
426 "ge>=" & -- Oge => ">="
427 "le<=" & -- Ole => "<="
428 "lt< " & -- Olt => "<"
429 "mo " & -- Omod => "mod"
430 "mu* " & -- Omutliply => "*"
431 "ne/=" & -- One => "/="
432 "no " & -- Onot => "not"
433 "or " & -- Oor => "or"
434 "re " & -- Orem => "rem"
435 "su- " & -- Osubtract => "-"
436 "xo "; -- Oxor => "xor"
441 Insert_Character ('"');
443 -- Search the map. Note that this loop must terminate, if
444 -- not we have some kind of internal error, and a constraint
445 -- error may be raised.
449 exit when Name_Buffer (Old) = Map (J)
450 and then Name_Buffer (Old + 1) = Map (J + 1);
454 -- Special operator name
456 if Map (J + 2) /= ' ' then
457 Insert_Character (Map (J + 2));
459 if Map (J + 3) /= ' ' then
460 Insert_Character (Map (J + 3));
463 Insert_Character ('"');
465 -- Skip past original operator name in input
467 while Old <= Name_Len
468 and then Name_Buffer (Old) in 'a' .. 'z'
473 -- For other operator names, leave them in lower case,
474 -- surrounded by apostrophes
477 -- Copy original operator name from input to output
479 while Old <= Name_Len
480 and then Name_Buffer (Old) in 'a' .. 'z'
485 Insert_Character ('"');
489 -- Else copy one character and keep going
496 -- Copy new buffer as result
499 Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
501 end Get_Decoded_Name_String;
503 -------------------------------------------
504 -- Get_Decoded_Name_String_With_Brackets --
505 -------------------------------------------
507 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
511 -- Case of operator name, normal decoding is fine
513 if Name_Buffer (1) = 'O' then
514 Get_Decoded_Name_String (Id);
516 -- For character literals, normal decoding is fine
518 elsif Name_Buffer (1) = 'Q' then
519 Get_Decoded_Name_String (Id);
521 -- Only remaining issue is U/W/WW sequences
524 Get_Name_String (Id);
527 while P < Name_Len loop
528 if Name_Buffer (P + 1) in 'A' .. 'Z' then
533 elsif Name_Buffer (P) = 'U' then
534 for J in reverse P + 3 .. P + Name_Len loop
535 Name_Buffer (J + 3) := Name_Buffer (J);
538 Name_Len := Name_Len + 3;
539 Name_Buffer (P + 3) := Name_Buffer (P + 2);
540 Name_Buffer (P + 2) := Name_Buffer (P + 1);
541 Name_Buffer (P) := '[';
542 Name_Buffer (P + 1) := '"';
543 Name_Buffer (P + 4) := '"';
544 Name_Buffer (P + 5) := ']';
547 -- WWhhhhhhhh encoding
549 elsif Name_Buffer (P) = 'W'
550 and then P + 9 <= Name_Len
551 and then Name_Buffer (P + 1) = 'W'
552 and then Name_Buffer (P + 2) not in 'A' .. 'Z'
553 and then Name_Buffer (P + 2) /= '_'
555 Name_Buffer (P + 12 .. Name_Len + 2) :=
556 Name_Buffer (P + 10 .. Name_Len);
557 Name_Buffer (P) := '[';
558 Name_Buffer (P + 1) := '"';
559 Name_Buffer (P + 10) := '"';
560 Name_Buffer (P + 11) := ']';
561 Name_Len := Name_Len + 2;
566 elsif Name_Buffer (P) = 'W'
567 and then P < Name_Len
568 and then Name_Buffer (P + 1) not in 'A' .. 'Z'
569 and then Name_Buffer (P + 1) /= '_'
571 Name_Buffer (P + 8 .. P + Name_Len + 3) :=
572 Name_Buffer (P + 5 .. Name_Len);
573 Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
574 Name_Buffer (P) := '[';
575 Name_Buffer (P + 1) := '"';
576 Name_Buffer (P + 6) := '"';
577 Name_Buffer (P + 7) := ']';
578 Name_Len := Name_Len + 3;
586 end Get_Decoded_Name_String_With_Brackets;
588 ------------------------
589 -- Get_Last_Two_Chars --
590 ------------------------
592 procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
593 NE : Name_Entry renames Name_Entries.Table (N);
594 NEL : constant Int := Int (NE.Name_Len);
598 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
599 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
604 end Get_Last_Two_Chars;
606 ---------------------
607 -- Get_Name_String --
608 ---------------------
610 -- Procedure version leaving result in Name_Buffer, length in Name_Len
612 procedure Get_Name_String (Id : Name_Id) is
616 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
618 S := Name_Entries.Table (Id).Name_Chars_Index;
619 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
621 for J in 1 .. Name_Len loop
622 Name_Buffer (J) := Name_Chars.Table (S + Int (J));
626 ---------------------
627 -- Get_Name_String --
628 ---------------------
630 -- Function version returning a string
632 function Get_Name_String (Id : Name_Id) return String is
636 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
637 S := Name_Entries.Table (Id).Name_Chars_Index;
640 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
643 for J in R'Range loop
644 R (J) := Name_Chars.Table (S + Int (J));
651 --------------------------------
652 -- Get_Name_String_And_Append --
653 --------------------------------
655 procedure Get_Name_String_And_Append (Id : Name_Id) is
659 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
661 S := Name_Entries.Table (Id).Name_Chars_Index;
663 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
664 Name_Len := Name_Len + 1;
665 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
667 end Get_Name_String_And_Append;
669 -------------------------
670 -- Get_Name_Table_Byte --
671 -------------------------
673 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
675 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
676 return Name_Entries.Table (Id).Byte_Info;
677 end Get_Name_Table_Byte;
679 -------------------------
680 -- Get_Name_Table_Info --
681 -------------------------
683 function Get_Name_Table_Info (Id : Name_Id) return Int is
685 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
686 return Name_Entries.Table (Id).Int_Info;
687 end Get_Name_Table_Info;
689 -----------------------------------------
690 -- Get_Unqualified_Decoded_Name_String --
691 -----------------------------------------
693 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
695 Get_Decoded_Name_String (Id);
696 Strip_Qualification_And_Suffixes;
697 end Get_Unqualified_Decoded_Name_String;
699 ---------------------------------
700 -- Get_Unqualified_Name_String --
701 ---------------------------------
703 procedure Get_Unqualified_Name_String (Id : Name_Id) is
705 Get_Name_String (Id);
706 Strip_Qualification_And_Suffixes;
707 end Get_Unqualified_Name_String;
713 function Hash return Hash_Index_Type is
715 -- For the cases of 1-12 characters, all characters participate in the
716 -- hash. The positioning is randomized, with the bias that characters
717 -- later on participate fully (i.e. are added towards the right side).
726 Character'Pos (Name_Buffer (1));
730 Character'Pos (Name_Buffer (1))) * 64 +
731 Character'Pos (Name_Buffer (2))) mod Hash_Num;
735 Character'Pos (Name_Buffer (1))) * 16 +
736 Character'Pos (Name_Buffer (3))) * 16 +
737 Character'Pos (Name_Buffer (2))) mod Hash_Num;
741 Character'Pos (Name_Buffer (1))) * 8 +
742 Character'Pos (Name_Buffer (2))) * 8 +
743 Character'Pos (Name_Buffer (3))) * 8 +
744 Character'Pos (Name_Buffer (4))) mod Hash_Num;
748 Character'Pos (Name_Buffer (4))) * 8 +
749 Character'Pos (Name_Buffer (1))) * 4 +
750 Character'Pos (Name_Buffer (3))) * 4 +
751 Character'Pos (Name_Buffer (5))) * 8 +
752 Character'Pos (Name_Buffer (2))) mod Hash_Num;
756 Character'Pos (Name_Buffer (5))) * 4 +
757 Character'Pos (Name_Buffer (1))) * 4 +
758 Character'Pos (Name_Buffer (4))) * 4 +
759 Character'Pos (Name_Buffer (2))) * 4 +
760 Character'Pos (Name_Buffer (6))) * 4 +
761 Character'Pos (Name_Buffer (3))) mod Hash_Num;
765 Character'Pos (Name_Buffer (4))) * 4 +
766 Character'Pos (Name_Buffer (3))) * 4 +
767 Character'Pos (Name_Buffer (1))) * 4 +
768 Character'Pos (Name_Buffer (2))) * 2 +
769 Character'Pos (Name_Buffer (5))) * 2 +
770 Character'Pos (Name_Buffer (7))) * 2 +
771 Character'Pos (Name_Buffer (6))) mod Hash_Num;
775 Character'Pos (Name_Buffer (2))) * 4 +
776 Character'Pos (Name_Buffer (1))) * 4 +
777 Character'Pos (Name_Buffer (3))) * 2 +
778 Character'Pos (Name_Buffer (5))) * 2 +
779 Character'Pos (Name_Buffer (7))) * 2 +
780 Character'Pos (Name_Buffer (6))) * 2 +
781 Character'Pos (Name_Buffer (4))) * 2 +
782 Character'Pos (Name_Buffer (8))) mod Hash_Num;
786 Character'Pos (Name_Buffer (2))) * 4 +
787 Character'Pos (Name_Buffer (1))) * 4 +
788 Character'Pos (Name_Buffer (3))) * 4 +
789 Character'Pos (Name_Buffer (4))) * 2 +
790 Character'Pos (Name_Buffer (8))) * 2 +
791 Character'Pos (Name_Buffer (7))) * 2 +
792 Character'Pos (Name_Buffer (5))) * 2 +
793 Character'Pos (Name_Buffer (6))) * 2 +
794 Character'Pos (Name_Buffer (9))) mod Hash_Num;
798 Character'Pos (Name_Buffer (01))) * 2 +
799 Character'Pos (Name_Buffer (02))) * 2 +
800 Character'Pos (Name_Buffer (08))) * 2 +
801 Character'Pos (Name_Buffer (03))) * 2 +
802 Character'Pos (Name_Buffer (04))) * 2 +
803 Character'Pos (Name_Buffer (09))) * 2 +
804 Character'Pos (Name_Buffer (06))) * 2 +
805 Character'Pos (Name_Buffer (05))) * 2 +
806 Character'Pos (Name_Buffer (07))) * 2 +
807 Character'Pos (Name_Buffer (10))) mod Hash_Num;
811 Character'Pos (Name_Buffer (05))) * 2 +
812 Character'Pos (Name_Buffer (01))) * 2 +
813 Character'Pos (Name_Buffer (06))) * 2 +
814 Character'Pos (Name_Buffer (09))) * 2 +
815 Character'Pos (Name_Buffer (07))) * 2 +
816 Character'Pos (Name_Buffer (03))) * 2 +
817 Character'Pos (Name_Buffer (08))) * 2 +
818 Character'Pos (Name_Buffer (02))) * 2 +
819 Character'Pos (Name_Buffer (10))) * 2 +
820 Character'Pos (Name_Buffer (04))) * 2 +
821 Character'Pos (Name_Buffer (11))) mod Hash_Num;
825 Character'Pos (Name_Buffer (03))) * 2 +
826 Character'Pos (Name_Buffer (02))) * 2 +
827 Character'Pos (Name_Buffer (05))) * 2 +
828 Character'Pos (Name_Buffer (01))) * 2 +
829 Character'Pos (Name_Buffer (06))) * 2 +
830 Character'Pos (Name_Buffer (04))) * 2 +
831 Character'Pos (Name_Buffer (08))) * 2 +
832 Character'Pos (Name_Buffer (11))) * 2 +
833 Character'Pos (Name_Buffer (07))) * 2 +
834 Character'Pos (Name_Buffer (09))) * 2 +
835 Character'Pos (Name_Buffer (10))) * 2 +
836 Character'Pos (Name_Buffer (12))) mod Hash_Num;
838 -- Names longer than 12 characters are handled by taking the first
839 -- 6 odd numbered characters and the last 6 even numbered characters.
841 when others => declare
842 Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
845 Character'Pos (Name_Buffer (01))) * 2 +
846 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
847 Character'Pos (Name_Buffer (03))) * 2 +
848 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
849 Character'Pos (Name_Buffer (05))) * 2 +
850 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
851 Character'Pos (Name_Buffer (07))) * 2 +
852 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
853 Character'Pos (Name_Buffer (09))) * 2 +
854 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
855 Character'Pos (Name_Buffer (11))) * 2 +
856 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
865 procedure Initialize is
870 -- Initialize entries for one character names
872 for C in Character loop
874 ((Name_Chars_Index => Name_Chars.Last,
878 Name_Has_No_Encodings => True,
879 Hash_Link => No_Name));
881 Name_Chars.Append (C);
882 Name_Chars.Append (ASCII.NUL);
887 for J in Hash_Index_Type loop
888 Hash_Table (J) := No_Name;
892 ----------------------
893 -- Is_Internal_Name --
894 ----------------------
896 -- Version taking an argument
898 function Is_Internal_Name (Id : Name_Id) return Boolean is
900 Get_Name_String (Id);
901 return Is_Internal_Name;
902 end Is_Internal_Name;
904 ----------------------
905 -- Is_Internal_Name --
906 ----------------------
908 -- Version taking its input from Name_Buffer
910 function Is_Internal_Name return Boolean is
912 if Name_Buffer (1) = '_'
913 or else Name_Buffer (Name_Len) = '_'
918 -- Test backwards, because we only want to test the last entity
919 -- name if the name we have is qualified with other entities.
921 for J in reverse 1 .. Name_Len loop
922 if Is_OK_Internal_Letter (Name_Buffer (J)) then
925 -- Quit if we come to terminating double underscore (note that
926 -- if the current character is an underscore, we know that
927 -- there is a previous character present, since we already
928 -- filtered out the case of Name_Buffer (1) = '_' above.
930 elsif Name_Buffer (J) = '_'
931 and then Name_Buffer (J - 1) = '_'
932 and then Name_Buffer (J - 2) /= '_'
940 end Is_Internal_Name;
942 ---------------------------
943 -- Is_OK_Internal_Letter --
944 ---------------------------
946 function Is_OK_Internal_Letter (C : Character) return Boolean is
948 return C in 'A' .. 'Z'
954 end Is_OK_Internal_Letter;
956 ----------------------
957 -- Is_Operator_Name --
958 ----------------------
960 function Is_Operator_Name (Id : Name_Id) return Boolean is
963 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
964 S := Name_Entries.Table (Id).Name_Chars_Index;
965 return Name_Chars.Table (S + 1) = 'O';
966 end Is_Operator_Name;
972 function Is_Valid_Name (Id : Name_Id) return Boolean is
974 return Id in Name_Entries.First .. Name_Entries.Last;
981 function Length_Of_Name (Id : Name_Id) return Nat is
983 return Int (Name_Entries.Table (Id).Name_Len);
992 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
993 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
994 Name_Chars.Locked := True;
995 Name_Entries.Locked := True;
997 Name_Entries.Release;
1000 ------------------------
1001 -- Name_Chars_Address --
1002 ------------------------
1004 function Name_Chars_Address return System.Address is
1006 return Name_Chars.Table (0)'Address;
1007 end Name_Chars_Address;
1013 function Name_Enter return Name_Id is
1016 ((Name_Chars_Index => Name_Chars.Last,
1017 Name_Len => Short (Name_Len),
1020 Name_Has_No_Encodings => False,
1021 Hash_Link => No_Name));
1023 -- Set corresponding string entry in the Name_Chars table
1025 for J in 1 .. Name_Len loop
1026 Name_Chars.Append (Name_Buffer (J));
1029 Name_Chars.Append (ASCII.NUL);
1031 return Name_Entries.Last;
1034 --------------------------
1035 -- Name_Entries_Address --
1036 --------------------------
1038 function Name_Entries_Address return System.Address is
1040 return Name_Entries.Table (First_Name_Id)'Address;
1041 end Name_Entries_Address;
1043 ------------------------
1044 -- Name_Entries_Count --
1045 ------------------------
1047 function Name_Entries_Count return Nat is
1049 return Int (Name_Entries.Last - Name_Entries.First + 1);
1050 end Name_Entries_Count;
1056 function Name_Find return Name_Id is
1058 -- Id of entry in hash search, and value to be returned
1061 -- Pointer into string table
1063 Hash_Index : Hash_Index_Type;
1064 -- Computed hash index
1067 -- Quick handling for one character names
1069 if Name_Len = 1 then
1070 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1072 -- Otherwise search hash table for existing matching entry
1075 Hash_Index := Namet.Hash;
1076 New_Id := Hash_Table (Hash_Index);
1078 if New_Id = No_Name then
1079 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1084 Integer (Name_Entries.Table (New_Id).Name_Len)
1089 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1091 for J in 1 .. Name_Len loop
1092 if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1099 -- Current entry in hash chain does not match
1102 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1103 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1105 Name_Entries.Table (New_Id).Hash_Link :=
1106 Name_Entries.Last + 1;
1112 -- We fall through here only if a matching entry was not found in the
1113 -- hash table. We now create a new entry in the names table. The hash
1114 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1117 ((Name_Chars_Index => Name_Chars.Last,
1118 Name_Len => Short (Name_Len),
1119 Hash_Link => No_Name,
1120 Name_Has_No_Encodings => False,
1124 -- Set corresponding string entry in the Name_Chars table
1126 for J in 1 .. Name_Len loop
1127 Name_Chars.Append (Name_Buffer (J));
1130 Name_Chars.Append (ASCII.NUL);
1132 return Name_Entries.Last;
1136 ----------------------
1137 -- Reset_Name_Table --
1138 ----------------------
1140 procedure Reset_Name_Table is
1142 for J in First_Name_Id .. Name_Entries.Last loop
1143 Name_Entries.Table (J).Int_Info := 0;
1144 Name_Entries.Table (J).Byte_Info := 0;
1146 end Reset_Name_Table;
1148 --------------------------------
1149 -- Set_Character_Literal_Name --
1150 --------------------------------
1152 procedure Set_Character_Literal_Name (C : Char_Code) is
1154 Name_Buffer (1) := 'Q';
1156 Store_Encoded_Character (C);
1157 end Set_Character_Literal_Name;
1159 -------------------------
1160 -- Set_Name_Table_Byte --
1161 -------------------------
1163 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1165 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1166 Name_Entries.Table (Id).Byte_Info := Val;
1167 end Set_Name_Table_Byte;
1169 -------------------------
1170 -- Set_Name_Table_Info --
1171 -------------------------
1173 procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1175 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1176 Name_Entries.Table (Id).Int_Info := Val;
1177 end Set_Name_Table_Info;
1179 -----------------------------
1180 -- Store_Encoded_Character --
1181 -----------------------------
1183 procedure Store_Encoded_Character (C : Char_Code) is
1185 procedure Set_Hex_Chars (C : Char_Code);
1186 -- Stores given value, which is in the range 0 .. 255, as two hex
1187 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1193 procedure Set_Hex_Chars (C : Char_Code) is
1194 Hexd : constant String := "0123456789abcdef";
1195 N : constant Natural := Natural (C);
1197 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1198 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1199 Name_Len := Name_Len + 2;
1202 -- Start of processing for Store_Encoded_Character
1205 Name_Len := Name_Len + 1;
1207 if In_Character_Range (C) then
1209 CC : constant Character := Get_Character (C);
1211 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1212 Name_Buffer (Name_Len) := CC;
1214 Name_Buffer (Name_Len) := 'U';
1219 elsif In_Wide_Character_Range (C) then
1220 Name_Buffer (Name_Len) := 'W';
1221 Set_Hex_Chars (C / 256);
1222 Set_Hex_Chars (C mod 256);
1225 Name_Buffer (Name_Len) := 'W';
1226 Name_Len := Name_Len + 1;
1227 Name_Buffer (Name_Len) := 'W';
1228 Set_Hex_Chars (C / 2 ** 24);
1229 Set_Hex_Chars ((C / 2 ** 16) mod 256);
1230 Set_Hex_Chars ((C / 256) mod 256);
1231 Set_Hex_Chars (C mod 256);
1233 end Store_Encoded_Character;
1235 --------------------------------------
1236 -- Strip_Qualification_And_Suffixes --
1237 --------------------------------------
1239 procedure Strip_Qualification_And_Suffixes is
1243 -- Strip package body qualification string off end
1245 for J in reverse 2 .. Name_Len loop
1246 if Name_Buffer (J) = 'X' then
1251 exit when Name_Buffer (J) /= 'b'
1252 and then Name_Buffer (J) /= 'n'
1253 and then Name_Buffer (J) /= 'p';
1256 -- Find rightmost __ or $ separator if one exists. First we position
1257 -- to start the search. If we have a character constant, position
1258 -- just before it, otherwise position to last character but one
1260 if Name_Buffer (Name_Len) = ''' then
1262 while J > 0 and then Name_Buffer (J) /= ''' loop
1270 -- Loop to search for rightmost __ or $ (homonym) separator
1274 -- If $ separator, homonym separator, so strip it and keep looking
1276 if Name_Buffer (J) = '$' then
1280 -- Else check for __ found
1282 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1284 -- Found __ so see if digit follows, and if so, this is a
1285 -- homonym separator, so strip it and keep looking.
1287 if Name_Buffer (J + 2) in '0' .. '9' then
1291 -- If not a homonym separator, then we simply strip the
1292 -- separator and everything that precedes it, and we are done
1295 Name_Buffer (1 .. Name_Len - J - 1) :=
1296 Name_Buffer (J + 2 .. Name_Len);
1297 Name_Len := Name_Len - J - 1;
1305 end Strip_Qualification_And_Suffixes;
1311 procedure Tree_Read is
1313 Name_Chars.Tree_Read;
1314 Name_Entries.Tree_Read;
1317 (Hash_Table'Address,
1318 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1325 procedure Tree_Write is
1327 Name_Chars.Tree_Write;
1328 Name_Entries.Tree_Write;
1331 (Hash_Table'Address,
1332 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1341 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1342 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1343 Name_Chars.Locked := False;
1344 Name_Entries.Locked := False;
1346 Name_Entries.Release;
1353 procedure wn (Id : Name_Id) is
1357 if not Id'Valid then
1358 Write_Str ("<invalid name_id>");
1360 elsif Id = No_Name then
1361 Write_Str ("<No_Name>");
1363 elsif Id = Error_Name then
1364 Write_Str ("<Error_Name>");
1367 S := Name_Entries.Table (Id).Name_Chars_Index;
1368 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1370 for J in 1 .. Name_Len loop
1371 Write_Char (Name_Chars.Table (S + Int (J)));
1382 procedure Write_Name (Id : Name_Id) is
1384 if Id >= First_Name_Id then
1385 Get_Name_String (Id);
1386 Write_Str (Name_Buffer (1 .. Name_Len));
1390 ------------------------
1391 -- Write_Name_Decoded --
1392 ------------------------
1394 procedure Write_Name_Decoded (Id : Name_Id) is
1396 if Id >= First_Name_Id then
1397 Get_Decoded_Name_String (Id);
1398 Write_Str (Name_Buffer (1 .. Name_Len));
1400 end Write_Name_Decoded;