1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 -- WARNING: There is a C version of this package. Any changes to this
37 -- source file must be properly reflected in the C header file a-namet.h
38 -- which is created manually from namet.ads and namet.adb.
40 with Debug; use Debug;
41 with Output; use Output;
42 with Tree_IO; use Tree_IO;
43 with Widechar; use Widechar;
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**12;
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 alogorithm.
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 return Hash_Index_Type;
79 -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
81 procedure Strip_Qualification_And_Suffixes;
82 -- Given an encoded entity name in Name_Buffer, 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. The
85 -- contents of Name_Buffer is modified by this call, and on return
86 -- Name_Buffer and Name_Len reflect the stripped name.
88 -----------------------------
89 -- Add_Char_To_Name_Buffer --
90 -----------------------------
92 procedure Add_Char_To_Name_Buffer (C : Character) is
94 if Name_Len < Name_Buffer'Last then
95 Name_Len := Name_Len + 1;
96 Name_Buffer (Name_Len) := C;
98 end Add_Char_To_Name_Buffer;
100 ----------------------------
101 -- Add_Nat_To_Name_Buffer --
102 ----------------------------
104 procedure Add_Nat_To_Name_Buffer (V : Nat) is
107 Add_Nat_To_Name_Buffer (V / 10);
110 Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
111 end Add_Nat_To_Name_Buffer;
113 ----------------------------
114 -- Add_Str_To_Name_Buffer --
115 ----------------------------
117 procedure Add_Str_To_Name_Buffer (S : String) is
119 for J in S'Range loop
120 Add_Char_To_Name_Buffer (S (J));
122 end Add_Str_To_Name_Buffer;
128 procedure Finalize is
129 Max_Chain_Length : constant := 50;
130 -- Max length of chains for which specific information is output
132 F : array (Int range 0 .. Max_Chain_Length) of Int;
133 -- N'th entry is number of chains of length N
136 -- Used to compute average number of probes
139 -- Number of symbols in table
144 for J in F'Range loop
148 for I in Hash_Index_Type loop
149 if Hash_Table (I) = No_Name then
153 Write_Str ("Hash_Table (");
155 Write_Str (") has ");
166 while N /= No_Name loop
167 N := Name_Entries.Table (N).Hash_Link;
172 Write_Str (" entries");
175 if C < Max_Chain_Length then
178 F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
183 while N /= No_Name loop
184 S := Name_Entries.Table (N).Name_Chars_Index;
187 for J in 1 .. Name_Entries.Table (N).Name_Len loop
188 Write_Char (Name_Chars.Table (S + Int (J)));
192 N := Name_Entries.Table (N).Hash_Link;
200 for I in Int range 0 .. Max_Chain_Length loop
202 Write_Str ("Number of hash chains of length ");
210 if I = Max_Chain_Length then
211 Write_Str (" or greater");
219 Nsyms := Nsyms + F (I);
220 Probes := Probes + F (I) * (1 + I) * 100;
226 Write_Str ("Average number of probes for lookup = ");
227 Probes := Probes / Nsyms;
228 Write_Int (Probes / 200);
230 Probes := (Probes mod 200) / 2;
231 Write_Char (Character'Val (48 + Probes / 10));
232 Write_Char (Character'Val (48 + Probes mod 10));
238 -----------------------------
239 -- Get_Decoded_Name_String --
240 -----------------------------
242 procedure Get_Decoded_Name_String (Id : Name_Id) is
247 Get_Name_String (Id);
249 -- Quick loop to see if there is anything special to do
257 C := Name_Buffer (P);
269 -- Here we have at least some encoding that we must decode
271 -- Here we have to decode one or more Uhh or Whhhh sequences
276 New_Buf : String (1 .. Name_Buffer'Last);
278 procedure Insert_Character (C : Character);
279 -- Insert a new character into output decoded name
281 procedure Copy_One_Character;
282 -- Copy a character from Name_Buffer to New_Buf. Includes case
283 -- of copying a Uhh or Whhhh sequence and decoding it.
285 function Hex (N : Natural) return Natural;
286 -- Scans past N digits using Old pointer and returns hex value
288 procedure Copy_One_Character is
292 C := Name_Buffer (Old);
296 Insert_Character (Character'Val (Hex (2)));
300 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
303 Insert_Character (Name_Buffer (Old));
306 end Copy_One_Character;
308 function Hex (N : Natural) return Natural is
314 C := Name_Buffer (Old);
317 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
320 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
321 else -- C in 'a' .. 'f'
322 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
329 procedure Insert_Character (C : Character) is
331 New_Len := New_Len + 1;
332 New_Buf (New_Len) := C;
333 end Insert_Character;
335 -- Actual decoding processing
341 -- Loop through characters of name
343 while Old <= Name_Len loop
345 -- Case of character literal, put apostrophes around character
347 if Name_Buffer (Old) = 'Q' then
349 Insert_Character (''');
351 Insert_Character (''');
353 -- Case of operator name
355 elsif Name_Buffer (Old) = 'O' then
359 -- This table maps the 2nd and 3rd characters of the name
360 -- into the required output. Two blanks means leave the
363 Map : constant String :=
364 "ab " & -- Oabs => "abs"
365 "ad+ " & -- Oadd => "+"
366 "an " & -- Oand => "and"
367 "co& " & -- Oconcat => "&"
368 "di/ " & -- Odivide => "/"
369 "eq= " & -- Oeq => "="
370 "ex**" & -- Oexpon => "**"
371 "gt> " & -- Ogt => ">"
372 "ge>=" & -- Oge => ">="
373 "le<=" & -- Ole => "<="
374 "lt< " & -- Olt => "<"
375 "mo " & -- Omod => "mod"
376 "mu* " & -- Omutliply => "*"
377 "ne/=" & -- One => "/="
378 "no " & -- Onot => "not"
379 "or " & -- Oor => "or"
380 "re " & -- Orem => "rem"
381 "su- " & -- Osubtract => "-"
382 "xo "; -- Oxor => "xor"
387 Insert_Character ('"');
389 -- Search the map. Note that this loop must terminate, if
390 -- not we have some kind of internal error, and a constraint
391 -- constraint error may be raised.
395 exit when Name_Buffer (Old) = Map (J)
396 and then Name_Buffer (Old + 1) = Map (J + 1);
400 -- Special operator name
402 if Map (J + 2) /= ' ' then
403 Insert_Character (Map (J + 2));
405 if Map (J + 3) /= ' ' then
406 Insert_Character (Map (J + 3));
409 Insert_Character ('"');
411 -- Skip past original operator name in input
413 while Old <= Name_Len
414 and then Name_Buffer (Old) in 'a' .. 'z'
419 -- For other operator names, leave them in lower case,
420 -- surrounded by apostrophes
423 -- Copy original operator name from input to output
425 while Old <= Name_Len
426 and then Name_Buffer (Old) in 'a' .. 'z'
431 Insert_Character ('"');
435 -- Else copy one character and keep going
442 -- Copy new buffer as result
445 Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
448 end Get_Decoded_Name_String;
450 -------------------------------------------
451 -- Get_Decoded_Name_String_With_Brackets --
452 -------------------------------------------
454 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
458 -- Case of operator name, normal decoding is fine
460 if Name_Buffer (1) = 'O' then
461 Get_Decoded_Name_String (Id);
463 -- For character literals, normal decoding is fine
465 elsif Name_Buffer (1) = 'Q' then
466 Get_Decoded_Name_String (Id);
468 -- Only remaining issue is U/W sequences
471 Get_Name_String (Id);
474 while P < Name_Len loop
475 if Name_Buffer (P) = 'U' then
476 for J in reverse P + 3 .. P + Name_Len loop
477 Name_Buffer (J + 3) := Name_Buffer (J);
480 Name_Len := Name_Len + 3;
481 Name_Buffer (P + 3) := Name_Buffer (P + 2);
482 Name_Buffer (P + 2) := Name_Buffer (P + 1);
483 Name_Buffer (P) := '[';
484 Name_Buffer (P + 1) := '"';
485 Name_Buffer (P + 4) := '"';
486 Name_Buffer (P + 5) := ']';
489 elsif Name_Buffer (P) = 'W' then
490 Name_Buffer (P + 8 .. P + Name_Len + 5) :=
491 Name_Buffer (P + 5 .. Name_Len);
492 Name_Buffer (P + 5) := Name_Buffer (P + 4);
493 Name_Buffer (P + 4) := Name_Buffer (P + 3);
494 Name_Buffer (P + 3) := Name_Buffer (P + 2);
495 Name_Buffer (P + 2) := Name_Buffer (P + 1);
496 Name_Buffer (P) := '[';
497 Name_Buffer (P + 1) := '"';
498 Name_Buffer (P + 6) := '"';
499 Name_Buffer (P + 7) := ']';
500 Name_Len := Name_Len + 5;
508 end Get_Decoded_Name_String_With_Brackets;
510 ---------------------
511 -- Get_Name_String --
512 ---------------------
514 procedure Get_Name_String (Id : Name_Id) is
518 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
520 S := Name_Entries.Table (Id).Name_Chars_Index;
521 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
523 for J in 1 .. Name_Len loop
524 Name_Buffer (J) := Name_Chars.Table (S + Int (J));
528 function Get_Name_String (Id : Name_Id) return String is
532 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
533 S := Name_Entries.Table (Id).Name_Chars_Index;
536 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
539 for J in R'Range loop
540 R (J) := Name_Chars.Table (S + Int (J));
547 --------------------------------
548 -- Get_Name_String_And_Append --
549 --------------------------------
551 procedure Get_Name_String_And_Append (Id : Name_Id) is
555 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
557 S := Name_Entries.Table (Id).Name_Chars_Index;
559 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
560 Name_Len := Name_Len + 1;
561 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
563 end Get_Name_String_And_Append;
565 -------------------------
566 -- Get_Name_Table_Byte --
567 -------------------------
569 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
571 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
572 return Name_Entries.Table (Id).Byte_Info;
573 end Get_Name_Table_Byte;
575 -------------------------
576 -- Get_Name_Table_Info --
577 -------------------------
579 function Get_Name_Table_Info (Id : Name_Id) return Int is
581 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
582 return Name_Entries.Table (Id).Int_Info;
583 end Get_Name_Table_Info;
585 -----------------------------------------
586 -- Get_Unqualified_Decoded_Name_String --
587 -----------------------------------------
589 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
591 Get_Decoded_Name_String (Id);
592 Strip_Qualification_And_Suffixes;
593 end Get_Unqualified_Decoded_Name_String;
595 ---------------------------------
596 -- Get_Unqualified_Name_String --
597 ---------------------------------
599 procedure Get_Unqualified_Name_String (Id : Name_Id) is
601 Get_Name_String (Id);
602 Strip_Qualification_And_Suffixes;
603 end Get_Unqualified_Name_String;
609 function Hash return Hash_Index_Type is
610 subtype Int_1_12 is Int range 1 .. 12;
611 -- Used to avoid when others on case jump below
613 Even_Name_Len : Integer;
614 -- Last even numbered position (used for >12 case)
618 -- Special test for 12 (rather than counting on a when others for the
619 -- case statement below) avoids some Ada compilers converting the case
620 -- statement into successive jumps.
622 -- The case of a name longer than 12 characters is handled by taking
623 -- the first 6 odd numbered characters and the last 6 even numbered
626 if Name_Len > 12 then
627 Even_Name_Len := (Name_Len) / 2 * 2;
630 Character'Pos (Name_Buffer (01))) * 2 +
631 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
632 Character'Pos (Name_Buffer (03))) * 2 +
633 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
634 Character'Pos (Name_Buffer (05))) * 2 +
635 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
636 Character'Pos (Name_Buffer (07))) * 2 +
637 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
638 Character'Pos (Name_Buffer (09))) * 2 +
639 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
640 Character'Pos (Name_Buffer (11))) * 2 +
641 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
644 -- For the cases of 1-12 characters, all characters participate in the
645 -- hash. The positioning is randomized, with the bias that characters
646 -- later on participate fully (i.e. are added towards the right side).
648 case Int_1_12 (Name_Len) is
652 Character'Pos (Name_Buffer (1));
656 Character'Pos (Name_Buffer (1))) * 64 +
657 Character'Pos (Name_Buffer (2))) mod Hash_Num;
661 Character'Pos (Name_Buffer (1))) * 16 +
662 Character'Pos (Name_Buffer (3))) * 16 +
663 Character'Pos (Name_Buffer (2))) mod Hash_Num;
667 Character'Pos (Name_Buffer (1))) * 8 +
668 Character'Pos (Name_Buffer (2))) * 8 +
669 Character'Pos (Name_Buffer (3))) * 8 +
670 Character'Pos (Name_Buffer (4))) mod Hash_Num;
674 Character'Pos (Name_Buffer (4))) * 8 +
675 Character'Pos (Name_Buffer (1))) * 4 +
676 Character'Pos (Name_Buffer (3))) * 4 +
677 Character'Pos (Name_Buffer (5))) * 8 +
678 Character'Pos (Name_Buffer (2))) mod Hash_Num;
682 Character'Pos (Name_Buffer (5))) * 4 +
683 Character'Pos (Name_Buffer (1))) * 4 +
684 Character'Pos (Name_Buffer (4))) * 4 +
685 Character'Pos (Name_Buffer (2))) * 4 +
686 Character'Pos (Name_Buffer (6))) * 4 +
687 Character'Pos (Name_Buffer (3))) mod Hash_Num;
691 Character'Pos (Name_Buffer (4))) * 4 +
692 Character'Pos (Name_Buffer (3))) * 4 +
693 Character'Pos (Name_Buffer (1))) * 4 +
694 Character'Pos (Name_Buffer (2))) * 2 +
695 Character'Pos (Name_Buffer (5))) * 2 +
696 Character'Pos (Name_Buffer (7))) * 2 +
697 Character'Pos (Name_Buffer (6))) mod Hash_Num;
701 Character'Pos (Name_Buffer (2))) * 4 +
702 Character'Pos (Name_Buffer (1))) * 4 +
703 Character'Pos (Name_Buffer (3))) * 2 +
704 Character'Pos (Name_Buffer (5))) * 2 +
705 Character'Pos (Name_Buffer (7))) * 2 +
706 Character'Pos (Name_Buffer (6))) * 2 +
707 Character'Pos (Name_Buffer (4))) * 2 +
708 Character'Pos (Name_Buffer (8))) mod Hash_Num;
712 Character'Pos (Name_Buffer (2))) * 4 +
713 Character'Pos (Name_Buffer (1))) * 4 +
714 Character'Pos (Name_Buffer (3))) * 4 +
715 Character'Pos (Name_Buffer (4))) * 2 +
716 Character'Pos (Name_Buffer (8))) * 2 +
717 Character'Pos (Name_Buffer (7))) * 2 +
718 Character'Pos (Name_Buffer (5))) * 2 +
719 Character'Pos (Name_Buffer (6))) * 2 +
720 Character'Pos (Name_Buffer (9))) mod Hash_Num;
724 Character'Pos (Name_Buffer (01))) * 2 +
725 Character'Pos (Name_Buffer (02))) * 2 +
726 Character'Pos (Name_Buffer (08))) * 2 +
727 Character'Pos (Name_Buffer (03))) * 2 +
728 Character'Pos (Name_Buffer (04))) * 2 +
729 Character'Pos (Name_Buffer (09))) * 2 +
730 Character'Pos (Name_Buffer (06))) * 2 +
731 Character'Pos (Name_Buffer (05))) * 2 +
732 Character'Pos (Name_Buffer (07))) * 2 +
733 Character'Pos (Name_Buffer (10))) mod Hash_Num;
737 Character'Pos (Name_Buffer (05))) * 2 +
738 Character'Pos (Name_Buffer (01))) * 2 +
739 Character'Pos (Name_Buffer (06))) * 2 +
740 Character'Pos (Name_Buffer (09))) * 2 +
741 Character'Pos (Name_Buffer (07))) * 2 +
742 Character'Pos (Name_Buffer (03))) * 2 +
743 Character'Pos (Name_Buffer (08))) * 2 +
744 Character'Pos (Name_Buffer (02))) * 2 +
745 Character'Pos (Name_Buffer (10))) * 2 +
746 Character'Pos (Name_Buffer (04))) * 2 +
747 Character'Pos (Name_Buffer (11))) mod Hash_Num;
751 Character'Pos (Name_Buffer (03))) * 2 +
752 Character'Pos (Name_Buffer (02))) * 2 +
753 Character'Pos (Name_Buffer (05))) * 2 +
754 Character'Pos (Name_Buffer (01))) * 2 +
755 Character'Pos (Name_Buffer (06))) * 2 +
756 Character'Pos (Name_Buffer (04))) * 2 +
757 Character'Pos (Name_Buffer (08))) * 2 +
758 Character'Pos (Name_Buffer (11))) * 2 +
759 Character'Pos (Name_Buffer (07))) * 2 +
760 Character'Pos (Name_Buffer (09))) * 2 +
761 Character'Pos (Name_Buffer (10))) * 2 +
762 Character'Pos (Name_Buffer (12))) mod Hash_Num;
771 procedure Initialize is
777 -- Initialize entries for one character names
779 for C in Character loop
780 Name_Entries.Increment_Last;
781 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
783 Name_Entries.Table (Name_Entries.Last).Name_Len := 1;
784 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
785 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
786 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
787 Name_Chars.Increment_Last;
788 Name_Chars.Table (Name_Chars.Last) := C;
789 Name_Chars.Increment_Last;
790 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
795 for J in Hash_Index_Type loop
796 Hash_Table (J) := No_Name;
800 ----------------------
801 -- Is_Internal_Name --
802 ----------------------
804 function Is_Internal_Name (Id : Name_Id) return Boolean is
806 Get_Name_String (Id);
807 return Is_Internal_Name;
808 end Is_Internal_Name;
810 function Is_Internal_Name return Boolean is
812 if Name_Buffer (1) = '_'
813 or else Name_Buffer (Name_Len) = '_'
818 -- Test backwards, because we only want to test the last entity
819 -- name if the name we have is qualified with other entities.
821 for J in reverse 1 .. Name_Len loop
822 if Is_OK_Internal_Letter (Name_Buffer (J)) then
825 -- Quit if we come to terminating double underscore (note that
826 -- if the current character is an underscore, we know that
827 -- there is a previous character present, since we already
828 -- filtered out the case of Name_Buffer (1) = '_' above.
830 elsif Name_Buffer (J) = '_'
831 and then Name_Buffer (J - 1) = '_'
832 and then Name_Buffer (J - 2) /= '_'
840 end Is_Internal_Name;
842 ---------------------------
843 -- Is_OK_Internal_Letter --
844 ---------------------------
846 function Is_OK_Internal_Letter (C : Character) return Boolean is
848 return C in 'A' .. 'Z'
854 end Is_OK_Internal_Letter;
860 function Length_Of_Name (Id : Name_Id) return Nat is
862 return Int (Name_Entries.Table (Id).Name_Len);
871 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
872 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
873 Name_Chars.Locked := True;
874 Name_Entries.Locked := True;
876 Name_Entries.Release;
879 ------------------------
880 -- Name_Chars_Address --
881 ------------------------
883 function Name_Chars_Address return System.Address is
885 return Name_Chars.Table (0)'Address;
886 end Name_Chars_Address;
892 function Name_Enter return Name_Id is
895 Name_Entries.Increment_Last;
896 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
898 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
899 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
900 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
901 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
903 -- Set corresponding string entry in the Name_Chars table
905 for J in 1 .. Name_Len loop
906 Name_Chars.Increment_Last;
907 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
910 Name_Chars.Increment_Last;
911 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
913 return Name_Entries.Last;
916 --------------------------
917 -- Name_Entries_Address --
918 --------------------------
920 function Name_Entries_Address return System.Address is
922 return Name_Entries.Table (First_Name_Id)'Address;
923 end Name_Entries_Address;
925 ------------------------
926 -- Name_Entries_Count --
927 ------------------------
929 function Name_Entries_Count return Nat is
931 return Int (Name_Entries.Last - Name_Entries.First + 1);
932 end Name_Entries_Count;
938 function Name_Find return Name_Id is
940 -- Id of entry in hash search, and value to be returned
943 -- Pointer into string table
945 Hash_Index : Hash_Index_Type;
946 -- Computed hash index
949 -- Quick handling for one character names
952 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
954 -- Otherwise search hash table for existing matching entry
957 Hash_Index := Namet.Hash;
958 New_Id := Hash_Table (Hash_Index);
960 if New_Id = No_Name then
961 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
966 Integer (Name_Entries.Table (New_Id).Name_Len)
971 S := Name_Entries.Table (New_Id).Name_Chars_Index;
973 for I in 1 .. Name_Len loop
974 if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then
981 -- Current entry in hash chain does not match
984 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
985 New_Id := Name_Entries.Table (New_Id).Hash_Link;
987 Name_Entries.Table (New_Id).Hash_Link :=
988 Name_Entries.Last + 1;
995 -- We fall through here only if a matching entry was not found in the
996 -- hash table. We now create a new entry in the names table. The hash
997 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
999 Name_Entries.Increment_Last;
1000 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
1002 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
1003 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
1004 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
1005 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
1007 -- Set corresponding string entry in the Name_Chars table
1009 for I in 1 .. Name_Len loop
1010 Name_Chars.Increment_Last;
1011 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
1014 Name_Chars.Increment_Last;
1015 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
1017 return Name_Entries.Last;
1021 ----------------------
1022 -- Reset_Name_Table --
1023 ----------------------
1025 procedure Reset_Name_Table is
1027 for J in First_Name_Id .. Name_Entries.Last loop
1028 Name_Entries.Table (J).Int_Info := 0;
1029 Name_Entries.Table (J).Byte_Info := 0;
1031 end Reset_Name_Table;
1033 --------------------------------
1034 -- Set_Character_Literal_Name --
1035 --------------------------------
1037 procedure Set_Character_Literal_Name (C : Char_Code) is
1039 Name_Buffer (1) := 'Q';
1041 Store_Encoded_Character (C);
1042 end Set_Character_Literal_Name;
1044 -------------------------
1045 -- Set_Name_Table_Byte --
1046 -------------------------
1048 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1050 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1051 Name_Entries.Table (Id).Byte_Info := Val;
1052 end Set_Name_Table_Byte;
1054 -------------------------
1055 -- Set_Name_Table_Info --
1056 -------------------------
1058 procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1060 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1061 Name_Entries.Table (Id).Int_Info := Val;
1062 end Set_Name_Table_Info;
1064 -----------------------------
1065 -- Store_Encoded_Character --
1066 -----------------------------
1068 procedure Store_Encoded_Character (C : Char_Code) is
1070 procedure Set_Hex_Chars (N : Natural);
1071 -- Stores given value, which is in the range 0 .. 255, as two hex
1072 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len
1074 procedure Set_Hex_Chars (N : Natural) is
1075 Hexd : constant String := "0123456789abcdef";
1078 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1079 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1080 Name_Len := Name_Len + 2;
1084 Name_Len := Name_Len + 1;
1086 if In_Character_Range (C) then
1088 CC : constant Character := Get_Character (C);
1091 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1092 Name_Buffer (Name_Len) := CC;
1095 Name_Buffer (Name_Len) := 'U';
1096 Set_Hex_Chars (Natural (C));
1101 Name_Buffer (Name_Len) := 'W';
1102 Set_Hex_Chars (Natural (C) / 256);
1103 Set_Hex_Chars (Natural (C) mod 256);
1106 end Store_Encoded_Character;
1108 --------------------------------------
1109 -- Strip_Qualification_And_Suffixes --
1110 --------------------------------------
1112 procedure Strip_Qualification_And_Suffixes is
1116 -- Strip package body qualification string off end
1118 for J in reverse 2 .. Name_Len loop
1119 if Name_Buffer (J) = 'X' then
1124 exit when Name_Buffer (J) /= 'b'
1125 and then Name_Buffer (J) /= 'n'
1126 and then Name_Buffer (J) /= 'p';
1129 -- Find rightmost __ or $ separator if one exists
1134 -- If $ separator, homonym separator, so strip it and keep looking
1136 if Name_Buffer (J) = '$' then
1140 -- Else check for __ found
1142 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1144 -- Found __ so see if digit follows, and if so, this is a
1145 -- homonym separator, so strip it and keep looking.
1147 if Name_Buffer (J + 2) in '0' .. '9' then
1151 -- If not a homonym separator, then we simply strip the
1152 -- separator and everything that precedes it, and we are done
1155 Name_Buffer (1 .. Name_Len - J - 1) :=
1156 Name_Buffer (J + 2 .. Name_Len);
1157 Name_Len := Name_Len - J - 1;
1165 end Strip_Qualification_And_Suffixes;
1171 procedure Tree_Read is
1173 Name_Chars.Tree_Read;
1174 Name_Entries.Tree_Read;
1177 (Hash_Table'Address,
1178 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1185 procedure Tree_Write is
1187 Name_Chars.Tree_Write;
1188 Name_Entries.Tree_Write;
1191 (Hash_Table'Address,
1192 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1201 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1202 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1203 Name_Chars.Locked := False;
1204 Name_Entries.Locked := False;
1206 Name_Entries.Release;
1213 procedure wn (Id : Name_Id) is
1223 procedure Write_Name (Id : Name_Id) is
1225 if Id >= First_Name_Id then
1226 Get_Name_String (Id);
1227 Write_Str (Name_Buffer (1 .. Name_Len));
1231 ------------------------
1232 -- Write_Name_Decoded --
1233 ------------------------
1235 procedure Write_Name_Decoded (Id : Name_Id) is
1237 if Id >= First_Name_Id then
1238 Get_Decoded_Name_String (Id);
1239 Write_Str (Name_Buffer (1 .. Name_Len));
1241 end Write_Name_Decoded;