1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 -------------------------------
871 -- Insert_Str_In_Name_Buffer --
872 -------------------------------
874 procedure Insert_Str_In_Name_Buffer
(S
: String; Index
: Positive) is
875 SL
: constant Natural := S
'Length;
877 Name_Buffer
(Index
+ SL
.. Name_Len
+ SL
) :=
878 Name_Buffer
(Index
.. Name_Len
);
879 Name_Buffer
(Index
.. Index
+ SL
- 1) := S
;
880 Name_Len
:= Name_Len
+ SL
;
881 end Insert_Str_In_Name_Buffer
;
883 ----------------------
884 -- Is_Internal_Name --
885 ----------------------
887 -- Version taking an argument
889 function Is_Internal_Name
(Id
: Name_Id
) return Boolean is
891 Get_Name_String
(Id
);
892 return Is_Internal_Name
;
893 end Is_Internal_Name
;
895 ----------------------
896 -- Is_Internal_Name --
897 ----------------------
899 -- Version taking its input from Name_Buffer
901 function Is_Internal_Name
return Boolean is
903 if Name_Buffer
(1) = '_'
904 or else Name_Buffer
(Name_Len
) = '_'
909 -- Test backwards, because we only want to test the last entity
910 -- name if the name we have is qualified with other entities.
912 for J
in reverse 1 .. Name_Len
loop
913 if Is_OK_Internal_Letter
(Name_Buffer
(J
)) then
916 -- Quit if we come to terminating double underscore (note that
917 -- if the current character is an underscore, we know that
918 -- there is a previous character present, since we already
919 -- filtered out the case of Name_Buffer (1) = '_' above.
921 elsif Name_Buffer
(J
) = '_'
922 and then Name_Buffer
(J
- 1) = '_'
923 and then Name_Buffer
(J
- 2) /= '_'
931 end Is_Internal_Name
;
933 ---------------------------
934 -- Is_OK_Internal_Letter --
935 ---------------------------
937 function Is_OK_Internal_Letter
(C
: Character) return Boolean is
939 return C
in 'A' .. 'Z'
945 end Is_OK_Internal_Letter
;
947 ----------------------
948 -- Is_Operator_Name --
949 ----------------------
951 function Is_Operator_Name
(Id
: Name_Id
) return Boolean is
954 pragma Assert
(Id
in Name_Entries
.First
.. Name_Entries
.Last
);
955 S
:= Name_Entries
.Table
(Id
).Name_Chars_Index
;
956 return Name_Chars
.Table
(S
+ 1) = 'O';
957 end Is_Operator_Name
;
963 function Is_Valid_Name
(Id
: Name_Id
) return Boolean is
965 return Id
in Name_Entries
.First
.. Name_Entries
.Last
;
972 function Length_Of_Name
(Id
: Name_Id
) return Nat
is
974 return Int
(Name_Entries
.Table
(Id
).Name_Len
);
983 Name_Chars
.Set_Last
(Name_Chars
.Last
+ Name_Chars_Reserve
);
984 Name_Entries
.Set_Last
(Name_Entries
.Last
+ Name_Entries_Reserve
);
985 Name_Chars
.Locked
:= True;
986 Name_Entries
.Locked
:= True;
988 Name_Entries
.Release
;
991 ------------------------
992 -- Name_Chars_Address --
993 ------------------------
995 function Name_Chars_Address
return System
.Address
is
997 return Name_Chars
.Table
(0)'Address;
998 end Name_Chars_Address
;
1004 function Name_Enter
return Name_Id
is
1007 ((Name_Chars_Index
=> Name_Chars
.Last
,
1008 Name_Len
=> Short
(Name_Len
),
1011 Name_Has_No_Encodings
=> False,
1012 Hash_Link
=> No_Name
));
1014 -- Set corresponding string entry in the Name_Chars table
1016 for J
in 1 .. Name_Len
loop
1017 Name_Chars
.Append
(Name_Buffer
(J
));
1020 Name_Chars
.Append
(ASCII
.NUL
);
1022 return Name_Entries
.Last
;
1025 --------------------------
1026 -- Name_Entries_Address --
1027 --------------------------
1029 function Name_Entries_Address
return System
.Address
is
1031 return Name_Entries
.Table
(First_Name_Id
)'Address;
1032 end Name_Entries_Address
;
1034 ------------------------
1035 -- Name_Entries_Count --
1036 ------------------------
1038 function Name_Entries_Count
return Nat
is
1040 return Int
(Name_Entries
.Last
- Name_Entries
.First
+ 1);
1041 end Name_Entries_Count
;
1047 function Name_Find
return Name_Id
is
1049 -- Id of entry in hash search, and value to be returned
1052 -- Pointer into string table
1054 Hash_Index
: Hash_Index_Type
;
1055 -- Computed hash index
1058 -- Quick handling for one character names
1060 if Name_Len
= 1 then
1061 return Name_Id
(First_Name_Id
+ Character'Pos (Name_Buffer
(1)));
1063 -- Otherwise search hash table for existing matching entry
1066 Hash_Index
:= Namet
.Hash
;
1067 New_Id
:= Hash_Table
(Hash_Index
);
1069 if New_Id
= No_Name
then
1070 Hash_Table
(Hash_Index
) := Name_Entries
.Last
+ 1;
1075 Integer (Name_Entries
.Table
(New_Id
).Name_Len
)
1080 S
:= Name_Entries
.Table
(New_Id
).Name_Chars_Index
;
1082 for J
in 1 .. Name_Len
loop
1083 if Name_Chars
.Table
(S
+ Int
(J
)) /= Name_Buffer
(J
) then
1090 -- Current entry in hash chain does not match
1093 if Name_Entries
.Table
(New_Id
).Hash_Link
/= No_Name
then
1094 New_Id
:= Name_Entries
.Table
(New_Id
).Hash_Link
;
1096 Name_Entries
.Table
(New_Id
).Hash_Link
:=
1097 Name_Entries
.Last
+ 1;
1103 -- We fall through here only if a matching entry was not found in the
1104 -- hash table. We now create a new entry in the names table. The hash
1105 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1108 ((Name_Chars_Index
=> Name_Chars
.Last
,
1109 Name_Len
=> Short
(Name_Len
),
1110 Hash_Link
=> No_Name
,
1111 Name_Has_No_Encodings
=> False,
1115 -- Set corresponding string entry in the Name_Chars table
1117 for J
in 1 .. Name_Len
loop
1118 Name_Chars
.Append
(Name_Buffer
(J
));
1121 Name_Chars
.Append
(ASCII
.NUL
);
1123 return Name_Entries
.Last
;
1131 procedure Reinitialize
is
1136 -- Initialize entries for one character names
1138 for C
in Character loop
1140 ((Name_Chars_Index
=> Name_Chars
.Last
,
1144 Name_Has_No_Encodings
=> True,
1145 Hash_Link
=> No_Name
));
1147 Name_Chars
.Append
(C
);
1148 Name_Chars
.Append
(ASCII
.NUL
);
1153 for J
in Hash_Index_Type
loop
1154 Hash_Table
(J
) := No_Name
;
1158 ----------------------
1159 -- Reset_Name_Table --
1160 ----------------------
1162 procedure Reset_Name_Table
is
1164 for J
in First_Name_Id
.. Name_Entries
.Last
loop
1165 Name_Entries
.Table
(J
).Int_Info
:= 0;
1166 Name_Entries
.Table
(J
).Byte_Info
:= 0;
1168 end Reset_Name_Table
;
1170 --------------------------------
1171 -- Set_Character_Literal_Name --
1172 --------------------------------
1174 procedure Set_Character_Literal_Name
(C
: Char_Code
) is
1176 Name_Buffer
(1) := 'Q';
1178 Store_Encoded_Character
(C
);
1179 end Set_Character_Literal_Name
;
1181 -------------------------
1182 -- Set_Name_Table_Byte --
1183 -------------------------
1185 procedure Set_Name_Table_Byte
(Id
: Name_Id
; Val
: Byte
) is
1187 pragma Assert
(Id
in Name_Entries
.First
.. Name_Entries
.Last
);
1188 Name_Entries
.Table
(Id
).Byte_Info
:= Val
;
1189 end Set_Name_Table_Byte
;
1191 -------------------------
1192 -- Set_Name_Table_Info --
1193 -------------------------
1195 procedure Set_Name_Table_Info
(Id
: Name_Id
; Val
: Int
) is
1197 pragma Assert
(Id
in Name_Entries
.First
.. Name_Entries
.Last
);
1198 Name_Entries
.Table
(Id
).Int_Info
:= Val
;
1199 end Set_Name_Table_Info
;
1201 -----------------------------
1202 -- Store_Encoded_Character --
1203 -----------------------------
1205 procedure Store_Encoded_Character
(C
: Char_Code
) is
1207 procedure Set_Hex_Chars
(C
: Char_Code
);
1208 -- Stores given value, which is in the range 0 .. 255, as two hex
1209 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1215 procedure Set_Hex_Chars
(C
: Char_Code
) is
1216 Hexd
: constant String := "0123456789abcdef";
1217 N
: constant Natural := Natural (C
);
1219 Name_Buffer
(Name_Len
+ 1) := Hexd
(N
/ 16 + 1);
1220 Name_Buffer
(Name_Len
+ 2) := Hexd
(N
mod 16 + 1);
1221 Name_Len
:= Name_Len
+ 2;
1224 -- Start of processing for Store_Encoded_Character
1227 Name_Len
:= Name_Len
+ 1;
1229 if In_Character_Range
(C
) then
1231 CC
: constant Character := Get_Character
(C
);
1233 if CC
in 'a' .. 'z' or else CC
in '0' .. '9' then
1234 Name_Buffer
(Name_Len
) := CC
;
1236 Name_Buffer
(Name_Len
) := 'U';
1241 elsif In_Wide_Character_Range
(C
) then
1242 Name_Buffer
(Name_Len
) := 'W';
1243 Set_Hex_Chars
(C
/ 256);
1244 Set_Hex_Chars
(C
mod 256);
1247 Name_Buffer
(Name_Len
) := 'W';
1248 Name_Len
:= Name_Len
+ 1;
1249 Name_Buffer
(Name_Len
) := 'W';
1250 Set_Hex_Chars
(C
/ 2 ** 24);
1251 Set_Hex_Chars
((C
/ 2 ** 16) mod 256);
1252 Set_Hex_Chars
((C
/ 256) mod 256);
1253 Set_Hex_Chars
(C
mod 256);
1255 end Store_Encoded_Character
;
1257 --------------------------------------
1258 -- Strip_Qualification_And_Suffixes --
1259 --------------------------------------
1261 procedure Strip_Qualification_And_Suffixes
is
1265 -- Strip package body qualification string off end
1267 for J
in reverse 2 .. Name_Len
loop
1268 if Name_Buffer
(J
) = 'X' then
1273 exit when Name_Buffer
(J
) /= 'b'
1274 and then Name_Buffer
(J
) /= 'n'
1275 and then Name_Buffer
(J
) /= 'p';
1278 -- Find rightmost __ or $ separator if one exists. First we position
1279 -- to start the search. If we have a character constant, position
1280 -- just before it, otherwise position to last character but one
1282 if Name_Buffer
(Name_Len
) = ''' then
1284 while J
> 0 and then Name_Buffer
(J
) /= ''' loop
1292 -- Loop to search for rightmost __ or $ (homonym) separator
1296 -- If $ separator, homonym separator, so strip it and keep looking
1298 if Name_Buffer
(J
) = '$' then
1302 -- Else check for __ found
1304 elsif Name_Buffer
(J
) = '_' and then Name_Buffer
(J
+ 1) = '_' then
1306 -- Found __ so see if digit follows, and if so, this is a
1307 -- homonym separator, so strip it and keep looking.
1309 if Name_Buffer
(J
+ 2) in '0' .. '9' then
1313 -- If not a homonym separator, then we simply strip the
1314 -- separator and everything that precedes it, and we are done
1317 Name_Buffer
(1 .. Name_Len
- J
- 1) :=
1318 Name_Buffer
(J
+ 2 .. Name_Len
);
1319 Name_Len
:= Name_Len
- J
- 1;
1327 end Strip_Qualification_And_Suffixes
;
1333 procedure Tree_Read
is
1335 Name_Chars
.Tree_Read
;
1336 Name_Entries
.Tree_Read
;
1339 (Hash_Table
'Address,
1340 Hash_Table
'Length * (Hash_Table
'Component_Size / Storage_Unit
));
1347 procedure Tree_Write
is
1349 Name_Chars
.Tree_Write
;
1350 Name_Entries
.Tree_Write
;
1353 (Hash_Table
'Address,
1354 Hash_Table
'Length * (Hash_Table
'Component_Size / Storage_Unit
));
1363 Name_Chars
.Set_Last
(Name_Chars
.Last
- Name_Chars_Reserve
);
1364 Name_Entries
.Set_Last
(Name_Entries
.Last
- Name_Entries_Reserve
);
1365 Name_Chars
.Locked
:= False;
1366 Name_Entries
.Locked
:= False;
1368 Name_Entries
.Release
;
1375 procedure wn
(Id
: Name_Id
) is
1379 if not Id
'Valid then
1380 Write_Str
("<invalid name_id>");
1382 elsif Id
= No_Name
then
1383 Write_Str
("<No_Name>");
1385 elsif Id
= Error_Name
then
1386 Write_Str
("<Error_Name>");
1389 S
:= Name_Entries
.Table
(Id
).Name_Chars_Index
;
1390 Name_Len
:= Natural (Name_Entries
.Table
(Id
).Name_Len
);
1392 for J
in 1 .. Name_Len
loop
1393 Write_Char
(Name_Chars
.Table
(S
+ Int
(J
)));
1404 procedure Write_Name
(Id
: Name_Id
) is
1406 if Id
>= First_Name_Id
then
1407 Get_Name_String
(Id
);
1408 Write_Str
(Name_Buffer
(1 .. Name_Len
));
1412 ------------------------
1413 -- Write_Name_Decoded --
1414 ------------------------
1416 procedure Write_Name_Decoded
(Id
: Name_Id
) is
1418 if Id
>= First_Name_Id
then
1419 Get_Decoded_Name_String
(Id
);
1420 Write_Str
(Name_Buffer
(1 .. Name_Len
));
1422 end Write_Name_Decoded
;
1424 -- Package initialization, initialize tables