1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- WARNING: There is a C version of this package. Any changes to this
35 -- source file must be properly reflected in the C header file a-namet.h
36 -- which is created manually from namet.ads and namet.adb.
38 with Debug; use Debug;
40 with Output; use Output;
41 with Tree_IO; use Tree_IO;
42 with Widechar; use Widechar;
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**12;
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 alogorithm.
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 return Hash_Index_Type;
78 -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
80 procedure Strip_Qualification_And_Suffixes;
81 -- Given an encoded entity name in Name_Buffer, 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. The
84 -- contents of Name_Buffer is modified by this call, and on return
85 -- Name_Buffer and Name_Len reflect the stripped name.
87 -----------------------------
88 -- Add_Char_To_Name_Buffer --
89 -----------------------------
91 procedure Add_Char_To_Name_Buffer (C : Character) is
93 if Name_Len < Name_Buffer'Last then
94 Name_Len := Name_Len + 1;
95 Name_Buffer (Name_Len) := C;
97 end Add_Char_To_Name_Buffer;
99 ----------------------------
100 -- Add_Nat_To_Name_Buffer --
101 ----------------------------
103 procedure Add_Nat_To_Name_Buffer (V : Nat) is
106 Add_Nat_To_Name_Buffer (V / 10);
109 Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
110 end Add_Nat_To_Name_Buffer;
112 ----------------------------
113 -- Add_Str_To_Name_Buffer --
114 ----------------------------
116 procedure Add_Str_To_Name_Buffer (S : String) is
118 for J in S'Range loop
119 Add_Char_To_Name_Buffer (S (J));
121 end Add_Str_To_Name_Buffer;
127 procedure Finalize is
128 Max_Chain_Length : constant := 50;
129 -- Max length of chains for which specific information is output
131 F : array (Int range 0 .. Max_Chain_Length) of Int;
132 -- N'th entry is number of chains of length N
135 -- Used to compute average number of probes
138 -- Number of symbols in table
142 for J in F'Range loop
146 for J in Hash_Index_Type loop
147 if Hash_Table (J) = No_Name then
151 Write_Str ("Hash_Table (");
153 Write_Str (") has ");
164 while N /= No_Name loop
165 N := Name_Entries.Table (N).Hash_Link;
170 Write_Str (" entries");
173 if C < Max_Chain_Length then
176 F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
181 while N /= No_Name loop
182 S := Name_Entries.Table (N).Name_Chars_Index;
185 for J in 1 .. Name_Entries.Table (N).Name_Len loop
186 Write_Char (Name_Chars.Table (S + Int (J)));
190 N := Name_Entries.Table (N).Hash_Link;
198 for J in Int range 0 .. Max_Chain_Length loop
200 Write_Str ("Number of hash chains of length ");
208 if J = Max_Chain_Length then
209 Write_Str (" or greater");
217 Nsyms := Nsyms + F (J);
218 Probes := Probes + F (J) * (1 + J) * 100;
224 Write_Str ("Average number of probes for lookup = ");
225 Probes := Probes / Nsyms;
226 Write_Int (Probes / 200);
228 Probes := (Probes mod 200) / 2;
229 Write_Char (Character'Val (48 + Probes / 10));
230 Write_Char (Character'Val (48 + Probes mod 10));
236 -----------------------------
237 -- Get_Decoded_Name_String --
238 -----------------------------
240 procedure Get_Decoded_Name_String (Id : Name_Id) is
245 Get_Name_String (Id);
247 -- Skip scan if we already know there are no encodings
249 if Name_Entries.Table (Id).Name_Has_No_Encodings then
253 -- Quick loop to see if there is anything special to do
258 Name_Entries.Table (Id).Name_Has_No_Encodings := True;
262 C := Name_Buffer (P);
274 -- Here we have at least some encoding that we must decode
279 New_Buf : String (1 .. Name_Buffer'Last);
281 procedure Copy_One_Character;
282 -- Copy a character from Name_Buffer to New_Buf. Includes case
283 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
285 function Hex (N : Natural) return Word;
286 -- Scans past N digits using Old pointer and returns hex value
288 procedure Insert_Character (C : Character);
289 -- Insert a new character into output decoded name
291 ------------------------
292 -- Copy_One_Character --
293 ------------------------
295 procedure Copy_One_Character is
299 C := Name_Buffer (Old);
301 -- U (upper half insertion case)
304 and then Old < Name_Len
305 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
306 and then Name_Buffer (Old + 1) /= '_'
310 -- If we have upper half encoding, then we have to set an
311 -- appropriate wide character sequence for this character.
313 if Upper_Half_Encoding then
314 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
316 -- For other encoding methods, upper half characters can
317 -- simply use their normal representation.
320 Insert_Character (Character'Val (Hex (2)));
323 -- WW (wide wide character insertion)
326 and then Old < Name_Len
327 and then Name_Buffer (Old + 1) = 'W'
330 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
332 -- W (wide character insertion)
335 and then Old < Name_Len
336 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
337 and then Name_Buffer (Old + 1) /= '_'
340 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
342 -- Any other character is copied unchanged
345 Insert_Character (C);
348 end Copy_One_Character;
354 function Hex (N : Natural) return Word is
360 C := Name_Buffer (Old);
363 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
366 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
367 else -- C in 'a' .. 'f'
368 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
375 ----------------------
376 -- Insert_Character --
377 ----------------------
379 procedure Insert_Character (C : Character) is
381 New_Len := New_Len + 1;
382 New_Buf (New_Len) := C;
383 end Insert_Character;
385 -- Start of processing for Decode
391 -- Loop through characters of name
393 while Old <= Name_Len loop
395 -- Case of character literal, put apostrophes around character
397 if Name_Buffer (Old) = 'Q'
398 and then Old < Name_Len
401 Insert_Character (''');
403 Insert_Character (''');
405 -- Case of operator name
407 elsif Name_Buffer (Old) = 'O'
408 and then Old < Name_Len
409 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
410 and then Name_Buffer (Old + 1) /= '_'
415 -- This table maps the 2nd and 3rd characters of the name
416 -- into the required output. Two blanks means leave the
419 Map : constant String :=
420 "ab " & -- Oabs => "abs"
421 "ad+ " & -- Oadd => "+"
422 "an " & -- Oand => "and"
423 "co& " & -- Oconcat => "&"
424 "di/ " & -- Odivide => "/"
425 "eq= " & -- Oeq => "="
426 "ex**" & -- Oexpon => "**"
427 "gt> " & -- Ogt => ">"
428 "ge>=" & -- Oge => ">="
429 "le<=" & -- Ole => "<="
430 "lt< " & -- Olt => "<"
431 "mo " & -- Omod => "mod"
432 "mu* " & -- Omutliply => "*"
433 "ne/=" & -- One => "/="
434 "no " & -- Onot => "not"
435 "or " & -- Oor => "or"
436 "re " & -- Orem => "rem"
437 "su- " & -- Osubtract => "-"
438 "xo "; -- Oxor => "xor"
443 Insert_Character ('"');
445 -- Search the map. Note that this loop must terminate, if
446 -- not we have some kind of internal error, and a constraint
447 -- constraint error may be raised.
451 exit when Name_Buffer (Old) = Map (J)
452 and then Name_Buffer (Old + 1) = Map (J + 1);
456 -- Special operator name
458 if Map (J + 2) /= ' ' then
459 Insert_Character (Map (J + 2));
461 if Map (J + 3) /= ' ' then
462 Insert_Character (Map (J + 3));
465 Insert_Character ('"');
467 -- Skip past original operator name in input
469 while Old <= Name_Len
470 and then Name_Buffer (Old) in 'a' .. 'z'
475 -- For other operator names, leave them in lower case,
476 -- surrounded by apostrophes
479 -- Copy original operator name from input to output
481 while Old <= Name_Len
482 and then Name_Buffer (Old) in 'a' .. 'z'
487 Insert_Character ('"');
491 -- Else copy one character and keep going
498 -- Copy new buffer as result
501 Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
503 end Get_Decoded_Name_String;
505 -------------------------------------------
506 -- Get_Decoded_Name_String_With_Brackets --
507 -------------------------------------------
509 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
513 -- Case of operator name, normal decoding is fine
515 if Name_Buffer (1) = 'O' then
516 Get_Decoded_Name_String (Id);
518 -- For character literals, normal decoding is fine
520 elsif Name_Buffer (1) = 'Q' then
521 Get_Decoded_Name_String (Id);
523 -- Only remaining issue is U/W/WW sequences
526 Get_Name_String (Id);
529 while P < Name_Len loop
530 if Name_Buffer (P + 1) in 'A' .. 'Z' then
535 elsif Name_Buffer (P) = 'U' then
536 for J in reverse P + 3 .. P + Name_Len loop
537 Name_Buffer (J + 3) := Name_Buffer (J);
540 Name_Len := Name_Len + 3;
541 Name_Buffer (P + 3) := Name_Buffer (P + 2);
542 Name_Buffer (P + 2) := Name_Buffer (P + 1);
543 Name_Buffer (P) := '[';
544 Name_Buffer (P + 1) := '"';
545 Name_Buffer (P + 4) := '"';
546 Name_Buffer (P + 5) := ']';
549 -- WWhhhhhhhh encoding
551 elsif Name_Buffer (P) = 'W'
552 and then P + 9 <= Name_Len
553 and then Name_Buffer (P + 1) = 'W'
554 and then Name_Buffer (P + 2) not in 'A' .. 'Z'
555 and then Name_Buffer (P + 2) /= '_'
557 Name_Buffer (P + 12 .. Name_Len + 2) :=
558 Name_Buffer (P + 10 .. Name_Len);
559 Name_Buffer (P) := '[';
560 Name_Buffer (P + 1) := '"';
561 Name_Buffer (P + 10) := '"';
562 Name_Buffer (P + 11) := ']';
563 Name_Len := Name_Len + 2;
568 elsif Name_Buffer (P) = 'W'
569 and then P < Name_Len
570 and then Name_Buffer (P + 1) not in 'A' .. 'Z'
571 and then Name_Buffer (P + 1) /= '_'
573 Name_Buffer (P + 8 .. P + Name_Len + 3) :=
574 Name_Buffer (P + 5 .. Name_Len);
575 Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
576 Name_Buffer (P) := '[';
577 Name_Buffer (P + 1) := '"';
578 Name_Buffer (P + 6) := '"';
579 Name_Buffer (P + 7) := ']';
580 Name_Len := Name_Len + 3;
588 end Get_Decoded_Name_String_With_Brackets;
590 ------------------------
591 -- Get_Last_Two_Chars --
592 ------------------------
594 procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
595 NE : Name_Entry renames Name_Entries.Table (N);
596 NEL : constant Int := Int (NE.Name_Len);
600 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
601 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
606 end Get_Last_Two_Chars;
608 ---------------------
609 -- Get_Name_String --
610 ---------------------
612 -- Procedure version leaving result in Name_Buffer, length in Name_Len
614 procedure Get_Name_String (Id : Name_Id) is
618 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
620 S := Name_Entries.Table (Id).Name_Chars_Index;
621 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
623 for J in 1 .. Name_Len loop
624 Name_Buffer (J) := Name_Chars.Table (S + Int (J));
628 ---------------------
629 -- Get_Name_String --
630 ---------------------
632 -- Function version returning a string
634 function Get_Name_String (Id : Name_Id) return String is
638 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
639 S := Name_Entries.Table (Id).Name_Chars_Index;
642 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
645 for J in R'Range loop
646 R (J) := Name_Chars.Table (S + Int (J));
653 --------------------------------
654 -- Get_Name_String_And_Append --
655 --------------------------------
657 procedure Get_Name_String_And_Append (Id : Name_Id) is
661 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
663 S := Name_Entries.Table (Id).Name_Chars_Index;
665 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
666 Name_Len := Name_Len + 1;
667 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
669 end Get_Name_String_And_Append;
671 -------------------------
672 -- Get_Name_Table_Byte --
673 -------------------------
675 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
677 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
678 return Name_Entries.Table (Id).Byte_Info;
679 end Get_Name_Table_Byte;
681 -------------------------
682 -- Get_Name_Table_Info --
683 -------------------------
685 function Get_Name_Table_Info (Id : Name_Id) return Int is
687 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
688 return Name_Entries.Table (Id).Int_Info;
689 end Get_Name_Table_Info;
691 -----------------------------------------
692 -- Get_Unqualified_Decoded_Name_String --
693 -----------------------------------------
695 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
697 Get_Decoded_Name_String (Id);
698 Strip_Qualification_And_Suffixes;
699 end Get_Unqualified_Decoded_Name_String;
701 ---------------------------------
702 -- Get_Unqualified_Name_String --
703 ---------------------------------
705 procedure Get_Unqualified_Name_String (Id : Name_Id) is
707 Get_Name_String (Id);
708 Strip_Qualification_And_Suffixes;
709 end Get_Unqualified_Name_String;
715 function Hash return Hash_Index_Type is
717 -- For the cases of 1-12 characters, all characters participate in the
718 -- hash. The positioning is randomized, with the bias that characters
719 -- later on participate fully (i.e. are added towards the right side).
728 Character'Pos (Name_Buffer (1));
732 Character'Pos (Name_Buffer (1))) * 64 +
733 Character'Pos (Name_Buffer (2))) mod Hash_Num;
737 Character'Pos (Name_Buffer (1))) * 16 +
738 Character'Pos (Name_Buffer (3))) * 16 +
739 Character'Pos (Name_Buffer (2))) mod Hash_Num;
743 Character'Pos (Name_Buffer (1))) * 8 +
744 Character'Pos (Name_Buffer (2))) * 8 +
745 Character'Pos (Name_Buffer (3))) * 8 +
746 Character'Pos (Name_Buffer (4))) mod Hash_Num;
750 Character'Pos (Name_Buffer (4))) * 8 +
751 Character'Pos (Name_Buffer (1))) * 4 +
752 Character'Pos (Name_Buffer (3))) * 4 +
753 Character'Pos (Name_Buffer (5))) * 8 +
754 Character'Pos (Name_Buffer (2))) mod Hash_Num;
758 Character'Pos (Name_Buffer (5))) * 4 +
759 Character'Pos (Name_Buffer (1))) * 4 +
760 Character'Pos (Name_Buffer (4))) * 4 +
761 Character'Pos (Name_Buffer (2))) * 4 +
762 Character'Pos (Name_Buffer (6))) * 4 +
763 Character'Pos (Name_Buffer (3))) mod Hash_Num;
767 Character'Pos (Name_Buffer (4))) * 4 +
768 Character'Pos (Name_Buffer (3))) * 4 +
769 Character'Pos (Name_Buffer (1))) * 4 +
770 Character'Pos (Name_Buffer (2))) * 2 +
771 Character'Pos (Name_Buffer (5))) * 2 +
772 Character'Pos (Name_Buffer (7))) * 2 +
773 Character'Pos (Name_Buffer (6))) mod Hash_Num;
777 Character'Pos (Name_Buffer (2))) * 4 +
778 Character'Pos (Name_Buffer (1))) * 4 +
779 Character'Pos (Name_Buffer (3))) * 2 +
780 Character'Pos (Name_Buffer (5))) * 2 +
781 Character'Pos (Name_Buffer (7))) * 2 +
782 Character'Pos (Name_Buffer (6))) * 2 +
783 Character'Pos (Name_Buffer (4))) * 2 +
784 Character'Pos (Name_Buffer (8))) mod Hash_Num;
788 Character'Pos (Name_Buffer (2))) * 4 +
789 Character'Pos (Name_Buffer (1))) * 4 +
790 Character'Pos (Name_Buffer (3))) * 4 +
791 Character'Pos (Name_Buffer (4))) * 2 +
792 Character'Pos (Name_Buffer (8))) * 2 +
793 Character'Pos (Name_Buffer (7))) * 2 +
794 Character'Pos (Name_Buffer (5))) * 2 +
795 Character'Pos (Name_Buffer (6))) * 2 +
796 Character'Pos (Name_Buffer (9))) mod Hash_Num;
800 Character'Pos (Name_Buffer (01))) * 2 +
801 Character'Pos (Name_Buffer (02))) * 2 +
802 Character'Pos (Name_Buffer (08))) * 2 +
803 Character'Pos (Name_Buffer (03))) * 2 +
804 Character'Pos (Name_Buffer (04))) * 2 +
805 Character'Pos (Name_Buffer (09))) * 2 +
806 Character'Pos (Name_Buffer (06))) * 2 +
807 Character'Pos (Name_Buffer (05))) * 2 +
808 Character'Pos (Name_Buffer (07))) * 2 +
809 Character'Pos (Name_Buffer (10))) mod Hash_Num;
813 Character'Pos (Name_Buffer (05))) * 2 +
814 Character'Pos (Name_Buffer (01))) * 2 +
815 Character'Pos (Name_Buffer (06))) * 2 +
816 Character'Pos (Name_Buffer (09))) * 2 +
817 Character'Pos (Name_Buffer (07))) * 2 +
818 Character'Pos (Name_Buffer (03))) * 2 +
819 Character'Pos (Name_Buffer (08))) * 2 +
820 Character'Pos (Name_Buffer (02))) * 2 +
821 Character'Pos (Name_Buffer (10))) * 2 +
822 Character'Pos (Name_Buffer (04))) * 2 +
823 Character'Pos (Name_Buffer (11))) mod Hash_Num;
827 Character'Pos (Name_Buffer (03))) * 2 +
828 Character'Pos (Name_Buffer (02))) * 2 +
829 Character'Pos (Name_Buffer (05))) * 2 +
830 Character'Pos (Name_Buffer (01))) * 2 +
831 Character'Pos (Name_Buffer (06))) * 2 +
832 Character'Pos (Name_Buffer (04))) * 2 +
833 Character'Pos (Name_Buffer (08))) * 2 +
834 Character'Pos (Name_Buffer (11))) * 2 +
835 Character'Pos (Name_Buffer (07))) * 2 +
836 Character'Pos (Name_Buffer (09))) * 2 +
837 Character'Pos (Name_Buffer (10))) * 2 +
838 Character'Pos (Name_Buffer (12))) mod Hash_Num;
840 -- Names longer than 12 characters are handled by taking the first
841 -- 6 odd numbered characters and the last 6 even numbered characters.
843 when others => declare
844 Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
847 Character'Pos (Name_Buffer (01))) * 2 +
848 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
849 Character'Pos (Name_Buffer (03))) * 2 +
850 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
851 Character'Pos (Name_Buffer (05))) * 2 +
852 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
853 Character'Pos (Name_Buffer (07))) * 2 +
854 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
855 Character'Pos (Name_Buffer (09))) * 2 +
856 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
857 Character'Pos (Name_Buffer (11))) * 2 +
858 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
867 procedure Initialize is
872 -- Initialize entries for one character names
874 for C in Character loop
876 ((Name_Chars_Index => Name_Chars.Last,
880 Name_Has_No_Encodings => True,
881 Hash_Link => No_Name));
883 Name_Chars.Append (C);
884 Name_Chars.Append (ASCII.NUL);
889 for J in Hash_Index_Type loop
890 Hash_Table (J) := No_Name;
894 ----------------------
895 -- Is_Internal_Name --
896 ----------------------
898 -- Version taking an argument
900 function Is_Internal_Name (Id : Name_Id) return Boolean is
902 Get_Name_String (Id);
903 return Is_Internal_Name;
904 end Is_Internal_Name;
906 ----------------------
907 -- Is_Internal_Name --
908 ----------------------
910 -- Version taking its input from Name_Buffer
912 function Is_Internal_Name return Boolean is
914 if Name_Buffer (1) = '_'
915 or else Name_Buffer (Name_Len) = '_'
920 -- Test backwards, because we only want to test the last entity
921 -- name if the name we have is qualified with other entities.
923 for J in reverse 1 .. Name_Len loop
924 if Is_OK_Internal_Letter (Name_Buffer (J)) then
927 -- Quit if we come to terminating double underscore (note that
928 -- if the current character is an underscore, we know that
929 -- there is a previous character present, since we already
930 -- filtered out the case of Name_Buffer (1) = '_' above.
932 elsif Name_Buffer (J) = '_'
933 and then Name_Buffer (J - 1) = '_'
934 and then Name_Buffer (J - 2) /= '_'
942 end Is_Internal_Name;
944 ---------------------------
945 -- Is_OK_Internal_Letter --
946 ---------------------------
948 function Is_OK_Internal_Letter (C : Character) return Boolean is
950 return C in 'A' .. 'Z'
956 end Is_OK_Internal_Letter;
958 ----------------------
959 -- Is_Operator_Name --
960 ----------------------
962 function Is_Operator_Name (Id : Name_Id) return Boolean is
965 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
966 S := Name_Entries.Table (Id).Name_Chars_Index;
967 return Name_Chars.Table (S + 1) = 'O';
968 end Is_Operator_Name;
974 function Is_Valid_Name (Id : Name_Id) return Boolean is
976 return Id in Name_Entries.First .. Name_Entries.Last;
983 function Length_Of_Name (Id : Name_Id) return Nat is
985 return Int (Name_Entries.Table (Id).Name_Len);
994 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
995 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
996 Name_Chars.Locked := True;
997 Name_Entries.Locked := True;
999 Name_Entries.Release;
1002 ------------------------
1003 -- Name_Chars_Address --
1004 ------------------------
1006 function Name_Chars_Address return System.Address is
1008 return Name_Chars.Table (0)'Address;
1009 end Name_Chars_Address;
1015 function Name_Enter return Name_Id is
1018 ((Name_Chars_Index => Name_Chars.Last,
1019 Name_Len => Short (Name_Len),
1022 Name_Has_No_Encodings => False,
1023 Hash_Link => No_Name));
1025 -- Set corresponding string entry in the Name_Chars table
1027 for J in 1 .. Name_Len loop
1028 Name_Chars.Append (Name_Buffer (J));
1031 Name_Chars.Append (ASCII.NUL);
1033 return Name_Entries.Last;
1036 --------------------------
1037 -- Name_Entries_Address --
1038 --------------------------
1040 function Name_Entries_Address return System.Address is
1042 return Name_Entries.Table (First_Name_Id)'Address;
1043 end Name_Entries_Address;
1045 ------------------------
1046 -- Name_Entries_Count --
1047 ------------------------
1049 function Name_Entries_Count return Nat is
1051 return Int (Name_Entries.Last - Name_Entries.First + 1);
1052 end Name_Entries_Count;
1058 function Name_Find return Name_Id is
1060 -- Id of entry in hash search, and value to be returned
1063 -- Pointer into string table
1065 Hash_Index : Hash_Index_Type;
1066 -- Computed hash index
1069 -- Quick handling for one character names
1071 if Name_Len = 1 then
1072 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1074 -- Otherwise search hash table for existing matching entry
1077 Hash_Index := Namet.Hash;
1078 New_Id := Hash_Table (Hash_Index);
1080 if New_Id = No_Name then
1081 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1086 Integer (Name_Entries.Table (New_Id).Name_Len)
1091 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1093 for J in 1 .. Name_Len loop
1094 if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1101 -- Current entry in hash chain does not match
1104 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1105 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1107 Name_Entries.Table (New_Id).Hash_Link :=
1108 Name_Entries.Last + 1;
1114 -- We fall through here only if a matching entry was not found in the
1115 -- hash table. We now create a new entry in the names table. The hash
1116 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1119 ((Name_Chars_Index => Name_Chars.Last,
1120 Name_Len => Short (Name_Len),
1121 Hash_Link => No_Name,
1122 Name_Has_No_Encodings => False,
1126 -- Set corresponding string entry in the Name_Chars table
1128 for J in 1 .. Name_Len loop
1129 Name_Chars.Append (Name_Buffer (J));
1132 Name_Chars.Append (ASCII.NUL);
1134 return Name_Entries.Last;
1138 ----------------------
1139 -- Reset_Name_Table --
1140 ----------------------
1142 procedure Reset_Name_Table is
1144 for J in First_Name_Id .. Name_Entries.Last loop
1145 Name_Entries.Table (J).Int_Info := 0;
1146 Name_Entries.Table (J).Byte_Info := 0;
1148 end Reset_Name_Table;
1150 --------------------------------
1151 -- Set_Character_Literal_Name --
1152 --------------------------------
1154 procedure Set_Character_Literal_Name (C : Char_Code) is
1156 Name_Buffer (1) := 'Q';
1158 Store_Encoded_Character (C);
1159 end Set_Character_Literal_Name;
1161 -------------------------
1162 -- Set_Name_Table_Byte --
1163 -------------------------
1165 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1167 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1168 Name_Entries.Table (Id).Byte_Info := Val;
1169 end Set_Name_Table_Byte;
1171 -------------------------
1172 -- Set_Name_Table_Info --
1173 -------------------------
1175 procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1177 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1178 Name_Entries.Table (Id).Int_Info := Val;
1179 end Set_Name_Table_Info;
1181 -----------------------------
1182 -- Store_Encoded_Character --
1183 -----------------------------
1185 procedure Store_Encoded_Character (C : Char_Code) is
1187 procedure Set_Hex_Chars (C : Char_Code);
1188 -- Stores given value, which is in the range 0 .. 255, as two hex
1189 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1195 procedure Set_Hex_Chars (C : Char_Code) is
1196 Hexd : constant String := "0123456789abcdef";
1197 N : constant Natural := Natural (C);
1199 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1200 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1201 Name_Len := Name_Len + 2;
1204 -- Start of processing for Store_Encoded_Character
1207 Name_Len := Name_Len + 1;
1209 if In_Character_Range (C) then
1211 CC : constant Character := Get_Character (C);
1213 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1214 Name_Buffer (Name_Len) := CC;
1216 Name_Buffer (Name_Len) := 'U';
1221 elsif In_Wide_Character_Range (C) then
1222 Name_Buffer (Name_Len) := 'W';
1223 Set_Hex_Chars (C / 256);
1224 Set_Hex_Chars (C mod 256);
1227 Name_Buffer (Name_Len) := 'W';
1228 Name_Len := Name_Len + 1;
1229 Name_Buffer (Name_Len) := 'W';
1230 Set_Hex_Chars (C / 2 ** 24);
1231 Set_Hex_Chars ((C / 2 ** 16) mod 256);
1232 Set_Hex_Chars ((C / 256) mod 256);
1233 Set_Hex_Chars (C mod 256);
1235 end Store_Encoded_Character;
1237 --------------------------------------
1238 -- Strip_Qualification_And_Suffixes --
1239 --------------------------------------
1241 procedure Strip_Qualification_And_Suffixes is
1245 -- Strip package body qualification string off end
1247 for J in reverse 2 .. Name_Len loop
1248 if Name_Buffer (J) = 'X' then
1253 exit when Name_Buffer (J) /= 'b'
1254 and then Name_Buffer (J) /= 'n'
1255 and then Name_Buffer (J) /= 'p';
1258 -- Find rightmost __ or $ separator if one exists. First we position
1259 -- to start the search. If we have a character constant, position
1260 -- just before it, otherwise position to last character but one
1262 if Name_Buffer (Name_Len) = ''' then
1264 while J > 0 and then Name_Buffer (J) /= ''' loop
1272 -- Loop to search for rightmost __ or $ (homonym) separator
1276 -- If $ separator, homonym separator, so strip it and keep looking
1278 if Name_Buffer (J) = '$' then
1282 -- Else check for __ found
1284 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1286 -- Found __ so see if digit follows, and if so, this is a
1287 -- homonym separator, so strip it and keep looking.
1289 if Name_Buffer (J + 2) in '0' .. '9' then
1293 -- If not a homonym separator, then we simply strip the
1294 -- separator and everything that precedes it, and we are done
1297 Name_Buffer (1 .. Name_Len - J - 1) :=
1298 Name_Buffer (J + 2 .. Name_Len);
1299 Name_Len := Name_Len - J - 1;
1307 end Strip_Qualification_And_Suffixes;
1313 procedure Tree_Read is
1315 Name_Chars.Tree_Read;
1316 Name_Entries.Tree_Read;
1319 (Hash_Table'Address,
1320 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1327 procedure Tree_Write is
1329 Name_Chars.Tree_Write;
1330 Name_Entries.Tree_Write;
1333 (Hash_Table'Address,
1334 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1343 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1344 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1345 Name_Chars.Locked := False;
1346 Name_Entries.Locked := False;
1348 Name_Entries.Release;
1355 procedure wn (Id : Name_Id) is
1359 if not Id'Valid then
1360 Write_Str ("<invalid name_id>");
1362 elsif Id = No_Name then
1363 Write_Str ("<No_Name>");
1365 elsif Id = Error_Name then
1366 Write_Str ("<Error_Name>");
1369 S := Name_Entries.Table (Id).Name_Chars_Index;
1370 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1372 for J in 1 .. Name_Len loop
1373 Write_Char (Name_Chars.Table (S + Int (J)));
1384 procedure Write_Name (Id : Name_Id) is
1386 if Id >= First_Name_Id then
1387 Get_Name_String (Id);
1388 Write_Str (Name_Buffer (1 .. Name_Len));
1392 ------------------------
1393 -- Write_Name_Decoded --
1394 ------------------------
1396 procedure Write_Name_Decoded (Id : Name_Id) is
1398 if Id >= First_Name_Id then
1399 Get_Decoded_Name_String (Id);
1400 Write_Str (Name_Buffer (1 .. Name_Len));
1402 end Write_Name_Decoded;