1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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;
39 with Output; use Output;
40 with Tree_IO; use Tree_IO;
41 with Widechar; use Widechar;
45 Name_Chars_Reserve : constant := 5000;
46 Name_Entries_Reserve : constant := 100;
47 -- The names table is locked during gigi processing, since gigi assumes
48 -- that the table does not move. After returning from gigi, the names
49 -- table is unlocked again, since writing library file information needs
50 -- to generate some extra names. To avoid the inefficiency of always
51 -- reallocating during this second unlocked phase, we reserve a bit of
52 -- extra space before doing the release call.
54 Hash_Num : constant Int := 2**12;
55 -- Number of headers in the hash table. Current hash algorithm is closely
56 -- tailored to this choice, so it can only be changed if a corresponding
57 -- change is made to the hash alogorithm.
59 Hash_Max : constant Int := Hash_Num - 1;
60 -- Indexes in the hash header table run from 0 to Hash_Num - 1
62 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
63 -- Range of hash index values
65 Hash_Table : array (Hash_Index_Type) of Name_Id;
66 -- The hash table is used to locate existing entries in the names table.
67 -- The entries point to the first names table entry whose hash value
68 -- matches the hash code. Then subsequent names table entries with the
69 -- same hash code value are linked through the Hash_Link fields.
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 function Hash return Hash_Index_Type;
77 -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
79 procedure Strip_Qualification_And_Suffixes;
80 -- Given an encoded entity name in Name_Buffer, remove package body
81 -- suffix as described for Strip_Package_Body_Suffix, and also remove
82 -- all qualification, i.e. names followed by two underscores. The
83 -- contents of Name_Buffer is modified by this call, and on return
84 -- Name_Buffer and Name_Len reflect the stripped name.
86 -----------------------------
87 -- Add_Char_To_Name_Buffer --
88 -----------------------------
90 procedure Add_Char_To_Name_Buffer (C : Character) is
92 if Name_Len < Name_Buffer'Last then
93 Name_Len := Name_Len + 1;
94 Name_Buffer (Name_Len) := C;
96 end Add_Char_To_Name_Buffer;
98 ----------------------------
99 -- Add_Nat_To_Name_Buffer --
100 ----------------------------
102 procedure Add_Nat_To_Name_Buffer (V : Nat) is
105 Add_Nat_To_Name_Buffer (V / 10);
108 Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
109 end Add_Nat_To_Name_Buffer;
111 ----------------------------
112 -- Add_Str_To_Name_Buffer --
113 ----------------------------
115 procedure Add_Str_To_Name_Buffer (S : String) is
117 for J in S'Range loop
118 Add_Char_To_Name_Buffer (S (J));
120 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 -- Quick loop to see if there is anything special to do
255 C := Name_Buffer (P);
267 -- Here we have at least some encoding that we must decode
272 New_Buf : String (1 .. Name_Buffer'Last);
274 procedure Copy_One_Character;
275 -- Copy a character from Name_Buffer to New_Buf. Includes case
276 -- of copying a Uhh or Whhhh sequence and decoding it.
278 function Hex (N : Natural) return Natural;
279 -- Scans past N digits using Old pointer and returns hex value
281 procedure Insert_Character (C : Character);
282 -- Insert a new character into output decoded name
284 ------------------------
285 -- Copy_One_Character --
286 ------------------------
288 procedure Copy_One_Character is
292 C := Name_Buffer (Old);
294 -- U (upper half insertion case)
297 and then Old < Name_Len
298 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
299 and then Name_Buffer (Old + 1) /= '_'
302 Insert_Character (Character'Val (Hex (2)));
304 -- W (wide character insertion)
307 and then Old < Name_Len
308 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
309 and then Name_Buffer (Old + 1) /= '_'
312 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
314 -- Any other character is copied unchanged
317 Insert_Character (C);
320 end Copy_One_Character;
326 function Hex (N : Natural) return Natural is
332 C := Name_Buffer (Old);
335 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
338 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
339 else -- C in 'a' .. 'f'
340 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
347 ----------------------
348 -- Insert_Character --
349 ----------------------
351 procedure Insert_Character (C : Character) is
353 New_Len := New_Len + 1;
354 New_Buf (New_Len) := C;
355 end Insert_Character;
357 -- Start of processing for Decode
363 -- Loop through characters of name
365 while Old <= Name_Len loop
367 -- Case of character literal, put apostrophes around character
369 if Name_Buffer (Old) = 'Q'
370 and then Old < Name_Len
373 Insert_Character (''');
375 Insert_Character (''');
377 -- Case of operator name
379 elsif Name_Buffer (Old) = 'O'
380 and then Old < Name_Len
381 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
382 and then Name_Buffer (Old + 1) /= '_'
387 -- This table maps the 2nd and 3rd characters of the name
388 -- into the required output. Two blanks means leave the
391 Map : constant String :=
392 "ab " & -- Oabs => "abs"
393 "ad+ " & -- Oadd => "+"
394 "an " & -- Oand => "and"
395 "co& " & -- Oconcat => "&"
396 "di/ " & -- Odivide => "/"
397 "eq= " & -- Oeq => "="
398 "ex**" & -- Oexpon => "**"
399 "gt> " & -- Ogt => ">"
400 "ge>=" & -- Oge => ">="
401 "le<=" & -- Ole => "<="
402 "lt< " & -- Olt => "<"
403 "mo " & -- Omod => "mod"
404 "mu* " & -- Omutliply => "*"
405 "ne/=" & -- One => "/="
406 "no " & -- Onot => "not"
407 "or " & -- Oor => "or"
408 "re " & -- Orem => "rem"
409 "su- " & -- Osubtract => "-"
410 "xo "; -- Oxor => "xor"
415 Insert_Character ('"');
417 -- Search the map. Note that this loop must terminate, if
418 -- not we have some kind of internal error, and a constraint
419 -- constraint error may be raised.
423 exit when Name_Buffer (Old) = Map (J)
424 and then Name_Buffer (Old + 1) = Map (J + 1);
428 -- Special operator name
430 if Map (J + 2) /= ' ' then
431 Insert_Character (Map (J + 2));
433 if Map (J + 3) /= ' ' then
434 Insert_Character (Map (J + 3));
437 Insert_Character ('"');
439 -- Skip past original operator name in input
441 while Old <= Name_Len
442 and then Name_Buffer (Old) in 'a' .. 'z'
447 -- For other operator names, leave them in lower case,
448 -- surrounded by apostrophes
451 -- Copy original operator name from input to output
453 while Old <= Name_Len
454 and then Name_Buffer (Old) in 'a' .. 'z'
459 Insert_Character ('"');
463 -- Else copy one character and keep going
470 -- Copy new buffer as result
473 Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
475 end Get_Decoded_Name_String;
477 -------------------------------------------
478 -- Get_Decoded_Name_String_With_Brackets --
479 -------------------------------------------
481 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
485 -- Case of operator name, normal decoding is fine
487 if Name_Buffer (1) = 'O' then
488 Get_Decoded_Name_String (Id);
490 -- For character literals, normal decoding is fine
492 elsif Name_Buffer (1) = 'Q' then
493 Get_Decoded_Name_String (Id);
495 -- Only remaining issue is U/W sequences
498 Get_Name_String (Id);
501 while P < Name_Len loop
502 if Name_Buffer (P + 1) in 'A' .. 'Z' then
505 elsif Name_Buffer (P) = 'U' then
506 for J in reverse P + 3 .. P + Name_Len loop
507 Name_Buffer (J + 3) := Name_Buffer (J);
510 Name_Len := Name_Len + 3;
511 Name_Buffer (P + 3) := Name_Buffer (P + 2);
512 Name_Buffer (P + 2) := Name_Buffer (P + 1);
513 Name_Buffer (P) := '[';
514 Name_Buffer (P + 1) := '"';
515 Name_Buffer (P + 4) := '"';
516 Name_Buffer (P + 5) := ']';
519 elsif Name_Buffer (P) = 'W' then
520 Name_Buffer (P + 8 .. P + Name_Len + 5) :=
521 Name_Buffer (P + 5 .. Name_Len);
522 Name_Buffer (P + 5) := Name_Buffer (P + 4);
523 Name_Buffer (P + 4) := Name_Buffer (P + 3);
524 Name_Buffer (P + 3) := Name_Buffer (P + 2);
525 Name_Buffer (P + 2) := Name_Buffer (P + 1);
526 Name_Buffer (P) := '[';
527 Name_Buffer (P + 1) := '"';
528 Name_Buffer (P + 6) := '"';
529 Name_Buffer (P + 7) := ']';
530 Name_Len := Name_Len + 5;
538 end Get_Decoded_Name_String_With_Brackets;
540 ------------------------
541 -- Get_Last_Two_Chars --
542 ------------------------
544 procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
545 NE : Name_Entry renames Name_Entries.Table (N);
546 NEL : constant Int := Int (NE.Name_Len);
550 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
551 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
556 end Get_Last_Two_Chars;
558 ---------------------
559 -- Get_Name_String --
560 ---------------------
562 -- Procedure version leaving result in Name_Buffer, length in Name_Len
564 procedure Get_Name_String (Id : Name_Id) is
568 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
570 S := Name_Entries.Table (Id).Name_Chars_Index;
571 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
573 for J in 1 .. Name_Len loop
574 Name_Buffer (J) := Name_Chars.Table (S + Int (J));
578 ---------------------
579 -- Get_Name_String --
580 ---------------------
582 -- Function version returning a string
584 function Get_Name_String (Id : Name_Id) return String is
588 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
589 S := Name_Entries.Table (Id).Name_Chars_Index;
592 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
595 for J in R'Range loop
596 R (J) := Name_Chars.Table (S + Int (J));
603 --------------------------------
604 -- Get_Name_String_And_Append --
605 --------------------------------
607 procedure Get_Name_String_And_Append (Id : Name_Id) is
611 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
613 S := Name_Entries.Table (Id).Name_Chars_Index;
615 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
616 Name_Len := Name_Len + 1;
617 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
619 end Get_Name_String_And_Append;
621 -------------------------
622 -- Get_Name_Table_Byte --
623 -------------------------
625 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
627 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
628 return Name_Entries.Table (Id).Byte_Info;
629 end Get_Name_Table_Byte;
631 -------------------------
632 -- Get_Name_Table_Info --
633 -------------------------
635 function Get_Name_Table_Info (Id : Name_Id) return Int is
637 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
638 return Name_Entries.Table (Id).Int_Info;
639 end Get_Name_Table_Info;
641 -----------------------------------------
642 -- Get_Unqualified_Decoded_Name_String --
643 -----------------------------------------
645 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
647 Get_Decoded_Name_String (Id);
648 Strip_Qualification_And_Suffixes;
649 end Get_Unqualified_Decoded_Name_String;
651 ---------------------------------
652 -- Get_Unqualified_Name_String --
653 ---------------------------------
655 procedure Get_Unqualified_Name_String (Id : Name_Id) is
657 Get_Name_String (Id);
658 Strip_Qualification_And_Suffixes;
659 end Get_Unqualified_Name_String;
665 function Hash return Hash_Index_Type is
667 -- For the cases of 1-12 characters, all characters participate in the
668 -- hash. The positioning is randomized, with the bias that characters
669 -- later on participate fully (i.e. are added towards the right side).
678 Character'Pos (Name_Buffer (1));
682 Character'Pos (Name_Buffer (1))) * 64 +
683 Character'Pos (Name_Buffer (2))) mod Hash_Num;
687 Character'Pos (Name_Buffer (1))) * 16 +
688 Character'Pos (Name_Buffer (3))) * 16 +
689 Character'Pos (Name_Buffer (2))) mod Hash_Num;
693 Character'Pos (Name_Buffer (1))) * 8 +
694 Character'Pos (Name_Buffer (2))) * 8 +
695 Character'Pos (Name_Buffer (3))) * 8 +
696 Character'Pos (Name_Buffer (4))) mod Hash_Num;
700 Character'Pos (Name_Buffer (4))) * 8 +
701 Character'Pos (Name_Buffer (1))) * 4 +
702 Character'Pos (Name_Buffer (3))) * 4 +
703 Character'Pos (Name_Buffer (5))) * 8 +
704 Character'Pos (Name_Buffer (2))) mod Hash_Num;
708 Character'Pos (Name_Buffer (5))) * 4 +
709 Character'Pos (Name_Buffer (1))) * 4 +
710 Character'Pos (Name_Buffer (4))) * 4 +
711 Character'Pos (Name_Buffer (2))) * 4 +
712 Character'Pos (Name_Buffer (6))) * 4 +
713 Character'Pos (Name_Buffer (3))) mod Hash_Num;
717 Character'Pos (Name_Buffer (4))) * 4 +
718 Character'Pos (Name_Buffer (3))) * 4 +
719 Character'Pos (Name_Buffer (1))) * 4 +
720 Character'Pos (Name_Buffer (2))) * 2 +
721 Character'Pos (Name_Buffer (5))) * 2 +
722 Character'Pos (Name_Buffer (7))) * 2 +
723 Character'Pos (Name_Buffer (6))) mod Hash_Num;
727 Character'Pos (Name_Buffer (2))) * 4 +
728 Character'Pos (Name_Buffer (1))) * 4 +
729 Character'Pos (Name_Buffer (3))) * 2 +
730 Character'Pos (Name_Buffer (5))) * 2 +
731 Character'Pos (Name_Buffer (7))) * 2 +
732 Character'Pos (Name_Buffer (6))) * 2 +
733 Character'Pos (Name_Buffer (4))) * 2 +
734 Character'Pos (Name_Buffer (8))) mod Hash_Num;
738 Character'Pos (Name_Buffer (2))) * 4 +
739 Character'Pos (Name_Buffer (1))) * 4 +
740 Character'Pos (Name_Buffer (3))) * 4 +
741 Character'Pos (Name_Buffer (4))) * 2 +
742 Character'Pos (Name_Buffer (8))) * 2 +
743 Character'Pos (Name_Buffer (7))) * 2 +
744 Character'Pos (Name_Buffer (5))) * 2 +
745 Character'Pos (Name_Buffer (6))) * 2 +
746 Character'Pos (Name_Buffer (9))) mod Hash_Num;
750 Character'Pos (Name_Buffer (01))) * 2 +
751 Character'Pos (Name_Buffer (02))) * 2 +
752 Character'Pos (Name_Buffer (08))) * 2 +
753 Character'Pos (Name_Buffer (03))) * 2 +
754 Character'Pos (Name_Buffer (04))) * 2 +
755 Character'Pos (Name_Buffer (09))) * 2 +
756 Character'Pos (Name_Buffer (06))) * 2 +
757 Character'Pos (Name_Buffer (05))) * 2 +
758 Character'Pos (Name_Buffer (07))) * 2 +
759 Character'Pos (Name_Buffer (10))) mod Hash_Num;
763 Character'Pos (Name_Buffer (05))) * 2 +
764 Character'Pos (Name_Buffer (01))) * 2 +
765 Character'Pos (Name_Buffer (06))) * 2 +
766 Character'Pos (Name_Buffer (09))) * 2 +
767 Character'Pos (Name_Buffer (07))) * 2 +
768 Character'Pos (Name_Buffer (03))) * 2 +
769 Character'Pos (Name_Buffer (08))) * 2 +
770 Character'Pos (Name_Buffer (02))) * 2 +
771 Character'Pos (Name_Buffer (10))) * 2 +
772 Character'Pos (Name_Buffer (04))) * 2 +
773 Character'Pos (Name_Buffer (11))) mod Hash_Num;
777 Character'Pos (Name_Buffer (03))) * 2 +
778 Character'Pos (Name_Buffer (02))) * 2 +
779 Character'Pos (Name_Buffer (05))) * 2 +
780 Character'Pos (Name_Buffer (01))) * 2 +
781 Character'Pos (Name_Buffer (06))) * 2 +
782 Character'Pos (Name_Buffer (04))) * 2 +
783 Character'Pos (Name_Buffer (08))) * 2 +
784 Character'Pos (Name_Buffer (11))) * 2 +
785 Character'Pos (Name_Buffer (07))) * 2 +
786 Character'Pos (Name_Buffer (09))) * 2 +
787 Character'Pos (Name_Buffer (10))) * 2 +
788 Character'Pos (Name_Buffer (12))) mod Hash_Num;
790 -- Names longer than 12 characters are handled by taking the first
791 -- 6 odd numbered characters and the last 6 even numbered characters.
793 when others => declare
794 Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
797 Character'Pos (Name_Buffer (01))) * 2 +
798 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
799 Character'Pos (Name_Buffer (03))) * 2 +
800 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
801 Character'Pos (Name_Buffer (05))) * 2 +
802 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
803 Character'Pos (Name_Buffer (07))) * 2 +
804 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
805 Character'Pos (Name_Buffer (09))) * 2 +
806 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
807 Character'Pos (Name_Buffer (11))) * 2 +
808 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
817 procedure Initialize is
822 -- Initialize entries for one character names
824 for C in Character loop
825 Name_Entries.Increment_Last;
826 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
828 Name_Entries.Table (Name_Entries.Last).Name_Len := 1;
829 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
830 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
831 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
832 Name_Chars.Increment_Last;
833 Name_Chars.Table (Name_Chars.Last) := C;
834 Name_Chars.Increment_Last;
835 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
840 for J in Hash_Index_Type loop
841 Hash_Table (J) := No_Name;
845 ----------------------
846 -- Is_Internal_Name --
847 ----------------------
849 -- Version taking an argument
851 function Is_Internal_Name (Id : Name_Id) return Boolean is
853 Get_Name_String (Id);
854 return Is_Internal_Name;
855 end Is_Internal_Name;
857 ----------------------
858 -- Is_Internal_Name --
859 ----------------------
861 -- Version taking its input from Name_Buffer
863 function Is_Internal_Name return Boolean is
865 if Name_Buffer (1) = '_'
866 or else Name_Buffer (Name_Len) = '_'
871 -- Test backwards, because we only want to test the last entity
872 -- name if the name we have is qualified with other entities.
874 for J in reverse 1 .. Name_Len loop
875 if Is_OK_Internal_Letter (Name_Buffer (J)) then
878 -- Quit if we come to terminating double underscore (note that
879 -- if the current character is an underscore, we know that
880 -- there is a previous character present, since we already
881 -- filtered out the case of Name_Buffer (1) = '_' above.
883 elsif Name_Buffer (J) = '_'
884 and then Name_Buffer (J - 1) = '_'
885 and then Name_Buffer (J - 2) /= '_'
893 end Is_Internal_Name;
895 ---------------------------
896 -- Is_OK_Internal_Letter --
897 ---------------------------
899 function Is_OK_Internal_Letter (C : Character) return Boolean is
901 return C in 'A' .. 'Z'
907 end Is_OK_Internal_Letter;
909 ----------------------
910 -- Is_Operator_Name --
911 ----------------------
913 function Is_Operator_Name (Id : Name_Id) return Boolean is
916 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
917 S := Name_Entries.Table (Id).Name_Chars_Index;
918 return Name_Chars.Table (S + 1) = 'O';
919 end Is_Operator_Name;
925 function Length_Of_Name (Id : Name_Id) return Nat is
927 return Int (Name_Entries.Table (Id).Name_Len);
936 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
937 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
938 Name_Chars.Locked := True;
939 Name_Entries.Locked := True;
941 Name_Entries.Release;
944 ------------------------
945 -- Name_Chars_Address --
946 ------------------------
948 function Name_Chars_Address return System.Address is
950 return Name_Chars.Table (0)'Address;
951 end Name_Chars_Address;
957 function Name_Enter return Name_Id is
959 Name_Entries.Increment_Last;
960 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
962 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
963 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
964 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
965 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
967 -- Set corresponding string entry in the Name_Chars table
969 for J in 1 .. Name_Len loop
970 Name_Chars.Increment_Last;
971 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
974 Name_Chars.Increment_Last;
975 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
977 return Name_Entries.Last;
980 --------------------------
981 -- Name_Entries_Address --
982 --------------------------
984 function Name_Entries_Address return System.Address is
986 return Name_Entries.Table (First_Name_Id)'Address;
987 end Name_Entries_Address;
989 ------------------------
990 -- Name_Entries_Count --
991 ------------------------
993 function Name_Entries_Count return Nat is
995 return Int (Name_Entries.Last - Name_Entries.First + 1);
996 end Name_Entries_Count;
1002 function Name_Find return Name_Id is
1004 -- Id of entry in hash search, and value to be returned
1007 -- Pointer into string table
1009 Hash_Index : Hash_Index_Type;
1010 -- Computed hash index
1013 -- Quick handling for one character names
1015 if Name_Len = 1 then
1016 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1018 -- Otherwise search hash table for existing matching entry
1021 Hash_Index := Namet.Hash;
1022 New_Id := Hash_Table (Hash_Index);
1024 if New_Id = No_Name then
1025 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1030 Integer (Name_Entries.Table (New_Id).Name_Len)
1035 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1037 for J in 1 .. Name_Len loop
1038 if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1045 -- Current entry in hash chain does not match
1048 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1049 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1051 Name_Entries.Table (New_Id).Hash_Link :=
1052 Name_Entries.Last + 1;
1059 -- We fall through here only if a matching entry was not found in the
1060 -- hash table. We now create a new entry in the names table. The hash
1061 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1063 Name_Entries.Increment_Last;
1064 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
1066 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
1067 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
1068 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
1069 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
1071 -- Set corresponding string entry in the Name_Chars table
1073 for J in 1 .. Name_Len loop
1074 Name_Chars.Increment_Last;
1075 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
1078 Name_Chars.Increment_Last;
1079 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
1081 return Name_Entries.Last;
1085 ----------------------
1086 -- Reset_Name_Table --
1087 ----------------------
1089 procedure Reset_Name_Table is
1091 for J in First_Name_Id .. Name_Entries.Last loop
1092 Name_Entries.Table (J).Int_Info := 0;
1093 Name_Entries.Table (J).Byte_Info := 0;
1095 end Reset_Name_Table;
1097 --------------------------------
1098 -- Set_Character_Literal_Name --
1099 --------------------------------
1101 procedure Set_Character_Literal_Name (C : Char_Code) is
1103 Name_Buffer (1) := 'Q';
1105 Store_Encoded_Character (C);
1106 end Set_Character_Literal_Name;
1108 -------------------------
1109 -- Set_Name_Table_Byte --
1110 -------------------------
1112 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1114 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1115 Name_Entries.Table (Id).Byte_Info := Val;
1116 end Set_Name_Table_Byte;
1118 -------------------------
1119 -- Set_Name_Table_Info --
1120 -------------------------
1122 procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1124 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1125 Name_Entries.Table (Id).Int_Info := Val;
1126 end Set_Name_Table_Info;
1128 -----------------------------
1129 -- Store_Encoded_Character --
1130 -----------------------------
1132 procedure Store_Encoded_Character (C : Char_Code) is
1134 procedure Set_Hex_Chars (N : Natural);
1135 -- Stores given value, which is in the range 0 .. 255, as two hex
1136 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len
1138 procedure Set_Hex_Chars (N : Natural) is
1139 Hexd : constant String := "0123456789abcdef";
1142 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1143 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1144 Name_Len := Name_Len + 2;
1148 Name_Len := Name_Len + 1;
1150 if In_Character_Range (C) then
1152 CC : constant Character := Get_Character (C);
1154 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1155 Name_Buffer (Name_Len) := CC;
1157 Name_Buffer (Name_Len) := 'U';
1158 Set_Hex_Chars (Natural (C));
1163 Name_Buffer (Name_Len) := 'W';
1164 Set_Hex_Chars (Natural (C) / 256);
1165 Set_Hex_Chars (Natural (C) mod 256);
1168 end Store_Encoded_Character;
1170 --------------------------------------
1171 -- Strip_Qualification_And_Suffixes --
1172 --------------------------------------
1174 procedure Strip_Qualification_And_Suffixes is
1178 -- Strip package body qualification string off end
1180 for J in reverse 2 .. Name_Len loop
1181 if Name_Buffer (J) = 'X' then
1186 exit when Name_Buffer (J) /= 'b'
1187 and then Name_Buffer (J) /= 'n'
1188 and then Name_Buffer (J) /= 'p';
1191 -- Find rightmost __ or $ separator if one exists. First we position
1192 -- to start the search. If we have a character constant, position
1193 -- just before it, otherwise position to last character but one
1195 if Name_Buffer (Name_Len) = ''' then
1197 while J > 0 and then Name_Buffer (J) /= ''' loop
1205 -- Loop to search for rightmost __ or $ (homonym) separator
1209 -- If $ separator, homonym separator, so strip it and keep looking
1211 if Name_Buffer (J) = '$' then
1215 -- Else check for __ found
1217 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1219 -- Found __ so see if digit follows, and if so, this is a
1220 -- homonym separator, so strip it and keep looking.
1222 if Name_Buffer (J + 2) in '0' .. '9' then
1226 -- If not a homonym separator, then we simply strip the
1227 -- separator and everything that precedes it, and we are done
1230 Name_Buffer (1 .. Name_Len - J - 1) :=
1231 Name_Buffer (J + 2 .. Name_Len);
1232 Name_Len := Name_Len - J - 1;
1240 end Strip_Qualification_And_Suffixes;
1246 procedure Tree_Read is
1248 Name_Chars.Tree_Read;
1249 Name_Entries.Tree_Read;
1252 (Hash_Table'Address,
1253 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1260 procedure Tree_Write is
1262 Name_Chars.Tree_Write;
1263 Name_Entries.Tree_Write;
1266 (Hash_Table'Address,
1267 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1276 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1277 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1278 Name_Chars.Locked := False;
1279 Name_Entries.Locked := False;
1281 Name_Entries.Release;
1288 procedure wn (Id : Name_Id) is
1298 procedure Write_Name (Id : Name_Id) is
1300 if Id >= First_Name_Id then
1301 Get_Name_String (Id);
1302 Write_Str (Name_Buffer (1 .. Name_Len));
1306 ------------------------
1307 -- Write_Name_Decoded --
1308 ------------------------
1310 procedure Write_Name_Decoded (Id : Name_Id) is
1312 if Id >= First_Name_Id then
1313 Get_Decoded_Name_String (Id);
1314 Write_Str (Name_Buffer (1 .. Name_Len));
1316 end Write_Name_Decoded;