1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- WARNING: There is a C version of this package. Any changes to this
27 -- source file must be properly reflected in the C header file namet.h
28 -- which is created manually from namet.ads and namet.adb.
30 with Debug
; use Debug
;
32 with Output
; use Output
;
35 with Interfaces
; use Interfaces
;
39 Name_Chars_Reserve
: constant := 5000;
40 Name_Entries_Reserve
: constant := 100;
41 -- The names table is locked during gigi processing, since gigi assumes
42 -- that the table does not move. After returning from gigi, the names
43 -- table is unlocked again, since writing library file information needs
44 -- to generate some extra names. To avoid the inefficiency of always
45 -- reallocating during this second unlocked phase, we reserve a bit of
46 -- extra space before doing the release call.
48 Hash_Num
: constant Int
:= 2**16;
49 -- Number of headers in the hash table. Current hash algorithm is closely
50 -- tailored to this choice, so it can only be changed if a corresponding
51 -- change is made to the hash algorithm.
53 Hash_Max
: constant Int
:= Hash_Num
- 1;
54 -- Indexes in the hash header table run from 0 to Hash_Num - 1
56 subtype Hash_Index_Type
is Int
range 0 .. Hash_Max
;
57 -- Range of hash index values
59 Hash_Table
: array (Hash_Index_Type
) of Name_Id
;
60 -- The hash table is used to locate existing entries in the names table.
61 -- The entries point to the first names table entry whose hash value
62 -- matches the hash code. Then subsequent names table entries with the
63 -- same hash code value are linked through the Hash_Link fields.
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 function Hash
(Buf
: Bounded_String
) return Hash_Index_Type
;
71 -- Compute hash code for name stored in Buf
73 procedure Strip_Qualification_And_Suffixes
(Buf
: in out Bounded_String
);
74 -- Given an encoded entity name in Buf, remove package body
75 -- suffix as described for Strip_Package_Body_Suffix, and also remove
76 -- all qualification, i.e. names followed by two underscores.
78 -----------------------------
79 -- Add_Char_To_Name_Buffer --
80 -----------------------------
82 procedure Add_Char_To_Name_Buffer
(C
: Character) is
84 Append
(Global_Name_Buffer
, C
);
85 end Add_Char_To_Name_Buffer
;
87 ----------------------------
88 -- Add_Nat_To_Name_Buffer --
89 ----------------------------
91 procedure Add_Nat_To_Name_Buffer
(V
: Nat
) is
93 Append
(Global_Name_Buffer
, V
);
94 end Add_Nat_To_Name_Buffer
;
96 ----------------------------
97 -- Add_Str_To_Name_Buffer --
98 ----------------------------
100 procedure Add_Str_To_Name_Buffer
(S
: String) is
102 Append
(Global_Name_Buffer
, S
);
103 end Add_Str_To_Name_Buffer
;
109 procedure Append
(Buf
: in out Bounded_String
; C
: Character) is
111 Buf
.Length
:= Buf
.Length
+ 1;
113 if Buf
.Length
> Buf
.Chars
'Last then
114 Write_Str
("Name buffer overflow; Max_Length = ");
115 Write_Int
(Int
(Buf
.Max_Length
));
120 Buf
.Chars
(Buf
.Length
) := C
;
123 procedure Append
(Buf
: in out Bounded_String
; V
: Nat
) is
126 Append
(Buf
, V
/ 10);
129 Append
(Buf
, Character'Val (Character'Pos ('0') + V
rem 10));
132 procedure Append
(Buf
: in out Bounded_String
; S
: String) is
133 First
: constant Natural := Buf
.Length
+ 1;
135 Buf
.Length
:= Buf
.Length
+ S
'Length;
137 if Buf
.Length
> Buf
.Chars
'Last then
138 Write_Str
("Name buffer overflow; Max_Length = ");
139 Write_Int
(Int
(Buf
.Max_Length
));
144 Buf
.Chars
(First
.. Buf
.Length
) := S
;
145 -- A loop calling Append(Character) would be cleaner, but this slice
146 -- assignment is substantially faster.
149 procedure Append
(Buf
: in out Bounded_String
; Buf2
: Bounded_String
) is
151 Append
(Buf
, Buf2
.Chars
(1 .. Buf2
.Length
));
154 procedure Append
(Buf
: in out Bounded_String
; Id
: Valid_Name_Id
) is
155 pragma Assert
(Is_Valid_Name
(Id
));
157 Index
: constant Int
:= Name_Entries
.Table
(Id
).Name_Chars_Index
;
158 Len
: constant Short
:= Name_Entries
.Table
(Id
).Name_Len
;
159 Chars
: Name_Chars
.Table_Type
renames
160 Name_Chars
.Table
(Index
+ 1 .. Index
+ Int
(Len
));
162 Append
(Buf
, String (Chars
));
169 procedure Append_Decoded
170 (Buf
: in out Bounded_String
;
173 Temp
: Bounded_String
;
175 function Has_Encodings
(Temp
: Bounded_String
) return Boolean;
176 -- True if Temp contains encoded characters. If not, we can set
177 -- Name_Has_No_Encodings to True below, and never call this again
178 -- on the same Name_Id.
180 function Has_Encodings
(Temp
: Bounded_String
) return Boolean is
182 for J
in 1 .. Temp
.Length
loop
183 if Temp
.Chars
(J
) in 'U' |
'W' |
'Q' |
'O' then
194 -- Skip scan if we already know there are no encodings (i.e. the first
195 -- time this was called on Id, the Has_Encodings call below returned
198 if Name_Entries
.Table
(Id
).Name_Has_No_Encodings
then
202 if not Has_Encodings
(Temp
) then
203 Name_Entries
.Table
(Id
).Name_Has_No_Encodings
:= True;
207 -- Here we have at least some encoding that we must decode
212 New_Buf
: String (1 .. Temp
.Chars
'Last);
214 procedure Copy_One_Character
;
215 -- Copy a character from Temp.Chars to New_Buf. Includes case
216 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
218 function Hex
(N
: Natural) return Word
;
219 -- Scans past N digits using Old pointer and returns hex value
221 procedure Insert_Character
(C
: Character);
222 -- Insert a new character into output decoded name
224 ------------------------
225 -- Copy_One_Character --
226 ------------------------
228 procedure Copy_One_Character
is
232 C
:= Temp
.Chars
(Old
);
234 -- U (upper half insertion case)
237 and then Old
< Temp
.Length
238 and then Temp
.Chars
(Old
+ 1) not in 'A' .. 'Z' |
'_'
242 -- If we have upper half encoding, then we have to set an
243 -- appropriate wide character sequence for this character.
245 if Upper_Half_Encoding
then
246 Widechar
.Set_Wide
(Char_Code
(Hex
(2)), New_Buf
, New_Len
);
248 -- For other encoding methods, upper half characters can
249 -- simply use their normal representation.
253 W2
: constant Word
:= Hex
(2);
255 pragma Assert
(W2
<= 255);
256 -- Add assumption to facilitate static analysis. Note
257 -- that we cannot use pragma Assume for bootstrap
259 Insert_Character
(Character'Val (W2
));
263 -- WW (wide wide character insertion)
266 and then Old
< Temp
.Length
267 and then Temp
.Chars
(Old
+ 1) = 'W'
270 Widechar
.Set_Wide
(Char_Code
(Hex
(8)), New_Buf
, New_Len
);
272 -- W (wide character insertion)
275 and then Old
< Temp
.Length
276 and then Temp
.Chars
(Old
+ 1) not in 'A' .. 'Z' |
'_'
279 Widechar
.Set_Wide
(Char_Code
(Hex
(4)), New_Buf
, New_Len
);
281 -- Any other character is copied unchanged
284 Insert_Character
(C
);
287 end Copy_One_Character
;
293 function Hex
(N
: Natural) return Word
is
299 C
:= Temp
.Chars
(Old
);
302 pragma Assert
(C
in '0' .. '9' |
'a' .. 'f');
305 T
:= 16 * T
+ Character'Pos (C
) - Character'Pos ('0');
306 else -- C in 'a' .. 'f'
307 T
:= 16 * T
+ Character'Pos (C
) - (Character'Pos ('a') - 10);
314 ----------------------
315 -- Insert_Character --
316 ----------------------
318 procedure Insert_Character
(C
: Character) is
320 New_Len
:= New_Len
+ 1;
321 New_Buf
(New_Len
) := C
;
322 end Insert_Character
;
324 -- Start of processing for Decode
330 -- Loop through characters of name
332 while Old
<= Temp
.Length
loop
334 -- Case of character literal, put apostrophes around character
336 if Temp
.Chars
(Old
) = 'Q'
337 and then Old
< Temp
.Length
340 Insert_Character
(''');
342 Insert_Character
(''');
344 -- Case of operator name
346 elsif Temp
.Chars
(Old
) = 'O'
347 and then Old
< Temp
.Length
348 and then Temp
.Chars
(Old
+ 1) not in 'A' .. 'Z' |
'_'
353 -- This table maps the 2nd and 3rd characters of the name
354 -- into the required output. Two blanks means leave the
357 Map
: constant String :=
358 "ab " & -- Oabs => "abs"
359 "ad+ " & -- Oadd => "+"
360 "an " & -- Oand => "and"
361 "co& " & -- Oconcat => "&"
362 "di/ " & -- Odivide => "/"
363 "eq= " & -- Oeq => "="
364 "ex**" & -- Oexpon => "**"
365 "gt> " & -- Ogt => ">"
366 "ge>=" & -- Oge => ">="
367 "le<=" & -- Ole => "<="
368 "lt< " & -- Olt => "<"
369 "mo " & -- Omod => "mod"
370 "mu* " & -- Omutliply => "*"
371 "ne/=" & -- One => "/="
372 "no " & -- Onot => "not"
373 "or " & -- Oor => "or"
374 "re " & -- Orem => "rem"
375 "su- " & -- Osubtract => "-"
376 "xo "; -- Oxor => "xor"
381 Insert_Character
('"');
383 -- Search the map. Note that this loop must terminate, if
384 -- not we have some kind of internal error, and a constraint
385 -- error may be raised.
389 exit when Temp
.Chars
(Old
) = Map
(J
)
390 and then Temp
.Chars
(Old
+ 1) = Map
(J
+ 1);
394 -- Special operator name
396 if Map
(J
+ 2) /= ' ' then
397 Insert_Character
(Map
(J
+ 2));
399 if Map
(J
+ 3) /= ' ' then
400 Insert_Character
(Map
(J
+ 3));
403 Insert_Character
('"');
405 -- Skip past original operator name in input
407 while Old
<= Temp
.Length
408 and then Temp
.Chars
(Old
) in 'a' .. 'z'
413 -- For other operator names, leave them in lower case,
414 -- surrounded by apostrophes
417 -- Copy original operator name from input to output
419 while Old
<= Temp
.Length
420 and then Temp
.Chars
(Old
) in 'a' .. 'z'
425 Insert_Character
('"');
429 -- Else copy one character and keep going
436 -- Copy new buffer as result
438 Temp
.Length
:= New_Len
;
439 Temp
.Chars
(1 .. New_Len
) := New_Buf
(1 .. New_Len
);
446 ----------------------------------
447 -- Append_Decoded_With_Brackets --
448 ----------------------------------
450 procedure Append_Decoded_With_Brackets
451 (Buf
: in out Bounded_String
;
457 -- Case of operator name, normal decoding is fine
459 if Buf
.Chars
(1) = 'O' then
460 Append_Decoded
(Buf
, Id
);
462 -- For character literals, normal decoding is fine
464 elsif Buf
.Chars
(1) = 'Q' then
465 Append_Decoded
(Buf
, Id
);
467 -- Only remaining issue is U/W/WW sequences
471 Temp
: Bounded_String
;
476 while P
< Temp
.Length
loop
477 if Temp
.Chars
(P
+ 1) in 'A' .. 'Z' then
482 elsif Temp
.Chars
(P
) = 'U' then
483 for J
in reverse P
+ 3 .. P
+ Temp
.Length
loop
484 Temp
.Chars
(J
+ 3) := Temp
.Chars
(J
);
487 Temp
.Length
:= Temp
.Length
+ 3;
488 Temp
.Chars
(P
+ 3) := Temp
.Chars
(P
+ 2);
489 Temp
.Chars
(P
+ 2) := Temp
.Chars
(P
+ 1);
490 Temp
.Chars
(P
) := '[';
491 Temp
.Chars
(P
+ 1) := '"';
492 Temp
.Chars
(P
+ 4) := '"';
493 Temp
.Chars
(P
+ 5) := ']';
496 -- WWhhhhhhhh encoding
498 elsif Temp
.Chars
(P
) = 'W'
499 and then P
+ 9 <= Temp
.Length
500 and then Temp
.Chars
(P
+ 1) = 'W'
501 and then Temp
.Chars
(P
+ 2) not in 'A' .. 'Z' |
'_'
503 Temp
.Chars
(P
+ 12 .. Temp
.Length
+ 2) :=
504 Temp
.Chars
(P
+ 10 .. Temp
.Length
);
505 Temp
.Chars
(P
) := '[';
506 Temp
.Chars
(P
+ 1) := '"';
507 Temp
.Chars
(P
+ 10) := '"';
508 Temp
.Chars
(P
+ 11) := ']';
509 Temp
.Length
:= Temp
.Length
+ 2;
514 elsif Temp
.Chars
(P
) = 'W'
515 and then P
< Temp
.Length
516 and then Temp
.Chars
(P
+ 1) not in 'A' .. 'Z' |
'_'
518 Temp
.Chars
(P
+ 8 .. P
+ Temp
.Length
+ 3) :=
519 Temp
.Chars
(P
+ 5 .. Temp
.Length
);
520 Temp
.Chars
(P
+ 2 .. P
+ 5) := Temp
.Chars
(P
+ 1 .. P
+ 4);
521 Temp
.Chars
(P
) := '[';
522 Temp
.Chars
(P
+ 1) := '"';
523 Temp
.Chars
(P
+ 6) := '"';
524 Temp
.Chars
(P
+ 7) := ']';
525 Temp
.Length
:= Temp
.Length
+ 3;
536 end Append_Decoded_With_Brackets
;
542 procedure Append_Encoded
(Buf
: in out Bounded_String
; C
: Char_Code
) is
543 procedure Set_Hex_Chars
(C
: Char_Code
);
544 -- Stores given value, which is in the range 0 .. 255, as two hex
545 -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length.
551 procedure Set_Hex_Chars
(C
: Char_Code
) is
552 Hexd
: constant String := "0123456789abcdef";
553 N
: constant Natural := Natural (C
);
555 Buf
.Chars
(Buf
.Length
+ 1) := Hexd
(N
/ 16 + 1);
556 Buf
.Chars
(Buf
.Length
+ 2) := Hexd
(N
mod 16 + 1);
557 Buf
.Length
:= Buf
.Length
+ 2;
560 -- Start of processing for Append_Encoded
563 Buf
.Length
:= Buf
.Length
+ 1;
565 if In_Character_Range
(C
) then
567 CC
: constant Character := Get_Character
(C
);
569 if CC
in 'a' .. 'z' |
'0' .. '9' then
570 Buf
.Chars
(Buf
.Length
) := CC
;
572 Buf
.Chars
(Buf
.Length
) := 'U';
577 elsif In_Wide_Character_Range
(C
) then
578 Buf
.Chars
(Buf
.Length
) := 'W';
579 Set_Hex_Chars
(C
/ 256);
580 Set_Hex_Chars
(C
mod 256);
583 Buf
.Chars
(Buf
.Length
) := 'W';
584 Buf
.Length
:= Buf
.Length
+ 1;
585 Buf
.Chars
(Buf
.Length
) := 'W';
586 Set_Hex_Chars
(C
/ 2 ** 24);
587 Set_Hex_Chars
((C
/ 2 ** 16) mod 256);
588 Set_Hex_Chars
((C
/ 256) mod 256);
589 Set_Hex_Chars
(C
mod 256);
593 ------------------------
594 -- Append_Unqualified --
595 ------------------------
597 procedure Append_Unqualified
598 (Buf
: in out Bounded_String
;
601 Temp
: Bounded_String
;
604 Strip_Qualification_And_Suffixes
(Temp
);
606 end Append_Unqualified
;
608 --------------------------------
609 -- Append_Unqualified_Decoded --
610 --------------------------------
612 procedure Append_Unqualified_Decoded
613 (Buf
: in out Bounded_String
;
616 Temp
: Bounded_String
;
618 Append_Decoded
(Temp
, Id
);
619 Strip_Qualification_And_Suffixes
(Temp
);
621 end Append_Unqualified_Decoded
;
623 --------------------------------
624 -- Destroy_Global_Name_Buffer --
625 --------------------------------
627 procedure Destroy_Global_Name_Buffer
is
629 -- Do the work. Needed only for "pragma Debug" below, so we don't do
630 -- anything in production mode.
634 Global_Name_Buffer
.Length
:= Global_Name_Buffer
.Max_Length
;
635 Global_Name_Buffer
.Chars
:= (others => '!');
637 pragma Debug
(Do_It
);
640 end Destroy_Global_Name_Buffer
;
646 procedure Finalize
is
647 F
: array (Int
range 0 .. 50) of Int
;
648 -- N'th entry is the number of chains of length N, except last entry,
649 -- which is the number of chains of length F'Last or more.
651 Max_Chain_Length
: Nat
:= 0;
652 -- Maximum length of all chains
655 -- Used to compute average number of probes
658 -- Number of symbols in table
660 Verbosity
: constant Int
range 1 .. 3 := 1;
661 pragma Warnings
(Off
, Verbosity
);
662 -- This constant indicates the level of verbosity in the output from
663 -- this procedure. Currently this can only be changed by editing the
664 -- declaration above and recompiling. That's good enough in practice,
665 -- since we very rarely need to use this debug option. Settings are:
667 -- 1 => print basic summary information
668 -- 2 => in addition print number of entries per hash chain
669 -- 3 => in addition print content of entries
671 Zero
: constant Int
:= Character'Pos ('0');
674 if not Debug_Flag_H
then
678 for J
in F
'Range loop
682 for J
in Hash_Index_Type
loop
683 if Hash_Table
(J
) = No_Name
then
696 while N
/= No_Name
loop
697 N
:= Name_Entries
.Table
(N
).Hash_Link
;
702 Probes
:= Probes
+ (1 + C
) * 100;
704 if C
> Max_Chain_Length
then
705 Max_Chain_Length
:= C
;
708 if Verbosity
>= 2 then
709 Write_Str
("Hash_Table (");
711 Write_Str
(") has ");
713 Write_Str
(" entries");
720 F
(F
'Last) := F
(F
'Last) + 1;
723 if Verbosity
>= 3 then
725 while N
/= No_Name
loop
726 S
:= Name_Entries
.Table
(N
).Name_Chars_Index
;
730 for J
in 1 .. Name_Entries
.Table
(N
).Name_Len
loop
731 Write_Char
(Name_Chars
.Table
(S
+ Int
(J
)));
736 N
:= Name_Entries
.Table
(N
).Hash_Link
;
745 for J
in F
'Range loop
747 Write_Str
("Number of hash chains of length ");
756 Write_Str
(" or greater");
765 -- Print out average number of probes, in the case where Name_Find is
766 -- called for a string that is already in the table.
769 Write_Str
("Average number of probes for lookup = ");
770 pragma Assert
(Nsyms
/= 0);
771 -- Add assumption to facilitate static analysis. Here Nsyms cannot be
772 -- zero because many symbols are added to the table by default.
773 Probes
:= Probes
/ Nsyms
;
774 Write_Int
(Probes
/ 200);
776 Probes
:= (Probes
mod 200) / 2;
777 Write_Char
(Character'Val (Zero
+ Probes
/ 10));
778 Write_Char
(Character'Val (Zero
+ Probes
mod 10));
781 Write_Str
("Max_Chain_Length = ");
782 Write_Int
(Max_Chain_Length
);
784 Write_Str
("Name_Chars'Length = ");
785 Write_Int
(Name_Chars
.Last
- Name_Chars
.First
+ 1);
787 Write_Str
("Name_Entries'Length = ");
788 Write_Int
(Int
(Name_Entries
.Last
- Name_Entries
.First
+ 1));
790 Write_Str
("Nsyms = ");
795 -----------------------------
796 -- Get_Decoded_Name_String --
797 -----------------------------
799 procedure Get_Decoded_Name_String
(Id
: Valid_Name_Id
) is
801 Global_Name_Buffer
.Length
:= 0;
802 Append_Decoded
(Global_Name_Buffer
, Id
);
803 end Get_Decoded_Name_String
;
805 -------------------------------------------
806 -- Get_Decoded_Name_String_With_Brackets --
807 -------------------------------------------
809 procedure Get_Decoded_Name_String_With_Brackets
(Id
: Valid_Name_Id
) is
811 Global_Name_Buffer
.Length
:= 0;
812 Append_Decoded_With_Brackets
(Global_Name_Buffer
, Id
);
813 end Get_Decoded_Name_String_With_Brackets
;
815 ------------------------
816 -- Get_Last_Two_Chars --
817 ------------------------
819 procedure Get_Last_Two_Chars
824 NE
: Name_Entry
renames Name_Entries
.Table
(N
);
825 NEL
: constant Int
:= Int
(NE
.Name_Len
);
829 C1
:= Name_Chars
.Table
(NE
.Name_Chars_Index
+ NEL
- 1);
830 C2
:= Name_Chars
.Table
(NE
.Name_Chars_Index
+ NEL
- 0);
835 end Get_Last_Two_Chars
;
837 ---------------------
838 -- Get_Name_String --
839 ---------------------
841 procedure Get_Name_String
(Id
: Valid_Name_Id
) is
843 Global_Name_Buffer
.Length
:= 0;
844 Append
(Global_Name_Buffer
, Id
);
847 function Get_Name_String
(Id
: Valid_Name_Id
) return String is
848 Buf
: Bounded_String
(Max_Length
=> Natural (Length_Of_Name
(Id
)));
854 --------------------------------
855 -- Get_Name_String_And_Append --
856 --------------------------------
858 procedure Get_Name_String_And_Append
(Id
: Valid_Name_Id
) is
860 Append
(Global_Name_Buffer
, Id
);
861 end Get_Name_String_And_Append
;
863 -----------------------------
864 -- Get_Name_Table_Boolean1 --
865 -----------------------------
867 function Get_Name_Table_Boolean1
(Id
: Valid_Name_Id
) return Boolean is
869 pragma Assert
(Is_Valid_Name
(Id
));
870 return Name_Entries
.Table
(Id
).Boolean1_Info
;
871 end Get_Name_Table_Boolean1
;
873 -----------------------------
874 -- Get_Name_Table_Boolean2 --
875 -----------------------------
877 function Get_Name_Table_Boolean2
(Id
: Valid_Name_Id
) return Boolean is
879 pragma Assert
(Is_Valid_Name
(Id
));
880 return Name_Entries
.Table
(Id
).Boolean2_Info
;
881 end Get_Name_Table_Boolean2
;
883 -----------------------------
884 -- Get_Name_Table_Boolean3 --
885 -----------------------------
887 function Get_Name_Table_Boolean3
(Id
: Valid_Name_Id
) return Boolean is
889 pragma Assert
(Is_Valid_Name
(Id
));
890 return Name_Entries
.Table
(Id
).Boolean3_Info
;
891 end Get_Name_Table_Boolean3
;
893 -------------------------
894 -- Get_Name_Table_Byte --
895 -------------------------
897 function Get_Name_Table_Byte
(Id
: Valid_Name_Id
) return Byte
is
899 pragma Assert
(Is_Valid_Name
(Id
));
900 return Name_Entries
.Table
(Id
).Byte_Info
;
901 end Get_Name_Table_Byte
;
903 -------------------------
904 -- Get_Name_Table_Int --
905 -------------------------
907 function Get_Name_Table_Int
(Id
: Valid_Name_Id
) return Int
is
909 pragma Assert
(Is_Valid_Name
(Id
));
910 return Name_Entries
.Table
(Id
).Int_Info
;
911 end Get_Name_Table_Int
;
913 -----------------------------------------
914 -- Get_Unqualified_Decoded_Name_String --
915 -----------------------------------------
917 procedure Get_Unqualified_Decoded_Name_String
(Id
: Valid_Name_Id
) is
919 Global_Name_Buffer
.Length
:= 0;
920 Append_Unqualified_Decoded
(Global_Name_Buffer
, Id
);
921 end Get_Unqualified_Decoded_Name_String
;
923 ---------------------------------
924 -- Get_Unqualified_Name_String --
925 ---------------------------------
927 procedure Get_Unqualified_Name_String
(Id
: Valid_Name_Id
) is
929 Global_Name_Buffer
.Length
:= 0;
930 Append_Unqualified
(Global_Name_Buffer
, Id
);
931 end Get_Unqualified_Name_String
;
937 function Hash
(Buf
: Bounded_String
) return Hash_Index_Type
is
939 -- This hash function looks at every character, in order to make it
940 -- likely that similar strings get different hash values. The rotate by
941 -- 7 bits has been determined empirically to be good, and it doesn't
942 -- lose bits like a shift would. The final conversion can't overflow,
943 -- because the table is 2**16 in size. This function probably needs to
944 -- be changed if the hash table size is changed.
946 -- Note that we could get some speed improvement by aligning the string
947 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement
948 -- a growable table. It doesn't seem worth the trouble to do those
951 Result
: Unsigned_16
:= 0;
954 for J
in 1 .. Buf
.Length
loop
955 Result
:= Rotate_Left
(Result
, 7) xor Character'Pos (Buf
.Chars
(J
));
958 return Hash_Index_Type
(Result
);
965 procedure Initialize
is
975 (Buf
: in out Bounded_String
;
979 SL
: constant Natural := S
'Length;
982 Buf
.Chars
(Index
+ SL
.. Buf
.Length
+ SL
) :=
983 Buf
.Chars
(Index
.. Buf
.Length
);
984 Buf
.Chars
(Index
.. Index
+ SL
- 1) := S
;
985 Buf
.Length
:= Buf
.Length
+ SL
;
988 -------------------------------
989 -- Insert_Str_In_Name_Buffer --
990 -------------------------------
992 procedure Insert_Str_In_Name_Buffer
(S
: String; Index
: Positive) is
994 Insert_Str
(Global_Name_Buffer
, S
, Index
);
995 end Insert_Str_In_Name_Buffer
;
997 ----------------------
998 -- Is_Internal_Name --
999 ----------------------
1001 function Is_Internal_Name
(Buf
: Bounded_String
) return Boolean is
1005 -- Any name starting or ending with underscore is internal
1007 if Buf
.Chars
(1) = '_' or else Buf
.Chars
(Buf
.Length
) = '_' then
1010 -- Allow quoted character
1012 elsif Buf
.Chars
(1) = ''' then
1015 -- All other cases, scan name
1018 -- Test backwards, because we only want to test the last entity
1019 -- name if the name we have is qualified with other entities.
1024 -- Skip stuff between brackets (A-F OK there)
1026 if Buf
.Chars
(J
) = ']' then
1029 exit when J
= 1 or else Buf
.Chars
(J
) = '[';
1032 -- Test for internal letter
1034 elsif Is_OK_Internal_Letter
(Buf
.Chars
(J
)) then
1037 -- Quit if we come to terminating double underscore (note that
1038 -- if the current character is an underscore, we know that
1039 -- there is a previous character present, since we already
1040 -- filtered out the case of Buf.Chars (1) = '_' above.
1042 elsif Buf
.Chars
(J
) = '_'
1043 and then Buf
.Chars
(J
- 1) = '_'
1044 and then Buf
.Chars
(J
- 2) /= '_'
1054 end Is_Internal_Name
;
1056 function Is_Internal_Name
(Id
: Valid_Name_Id
) return Boolean is
1057 Buf
: Bounded_String
(Max_Length
=> Natural (Length_Of_Name
(Id
)));
1060 return Is_Internal_Name
(Buf
);
1061 end Is_Internal_Name
;
1063 function Is_Internal_Name
return Boolean is
1065 return Is_Internal_Name
(Global_Name_Buffer
);
1066 end Is_Internal_Name
;
1068 ---------------------------
1069 -- Is_OK_Internal_Letter --
1070 ---------------------------
1072 function Is_OK_Internal_Letter
(C
: Character) return Boolean is
1074 return C
in 'A' .. 'Z' and then C
not in 'O' |
'Q' |
'U' |
'W' |
'X';
1075 end Is_OK_Internal_Letter
;
1077 ----------------------
1078 -- Is_Operator_Name --
1079 ----------------------
1081 function Is_Operator_Name
(Id
: Valid_Name_Id
) return Boolean is
1084 pragma Assert
(Is_Valid_Name
(Id
));
1085 S
:= Name_Entries
.Table
(Id
).Name_Chars_Index
;
1086 return Name_Chars
.Table
(S
+ 1) = 'O';
1087 end Is_Operator_Name
;
1093 function Is_Valid_Name
(Id
: Name_Id
) return Boolean is
1095 return Id
in Name_Entries
.First
.. Name_Entries
.Last
;
1102 function Last_Name_Id
return Name_Id
is
1104 return Name_Id
(Int
(First_Name_Id
) + Name_Entries_Count
- 1);
1107 --------------------
1108 -- Length_Of_Name --
1109 --------------------
1111 function Length_Of_Name
(Id
: Valid_Name_Id
) return Nat
is
1113 return Int
(Name_Entries
.Table
(Id
).Name_Len
);
1122 Name_Chars
.Set_Last
(Name_Chars
.Last
+ Name_Chars_Reserve
);
1123 Name_Entries
.Set_Last
(Name_Entries
.Last
+ Name_Entries_Reserve
);
1125 Name_Chars
.Locked
:= True;
1126 Name_Entries
.Release
;
1127 Name_Entries
.Locked
:= True;
1135 (Buf
: Bounded_String
:= Global_Name_Buffer
) return Valid_Name_Id
1139 ((Name_Chars_Index
=> Name_Chars
.Last
,
1140 Name_Len
=> Short
(Buf
.Length
),
1143 Hash_Link
=> No_Name
,
1144 Name_Has_No_Encodings
=> False,
1145 Boolean1_Info
=> False,
1146 Boolean2_Info
=> False,
1147 Boolean3_Info
=> False,
1150 -- Set corresponding string entry in the Name_Chars table
1152 for J
in 1 .. Buf
.Length
loop
1153 Name_Chars
.Append
(Buf
.Chars
(J
));
1156 Name_Chars
.Append
(ASCII
.NUL
);
1158 return Name_Entries
.Last
;
1161 function Name_Enter
(S
: String) return Valid_Name_Id
is
1162 Buf
: Bounded_String
(Max_Length
=> S
'Length);
1165 return Name_Enter
(Buf
);
1168 ------------------------
1169 -- Name_Entries_Count --
1170 ------------------------
1172 function Name_Entries_Count
return Nat
is
1174 return Int
(Name_Entries
.Last
- Name_Entries
.First
+ 1);
1175 end Name_Entries_Count
;
1182 (Buf
: Bounded_String
:= Global_Name_Buffer
) return Valid_Name_Id
1185 -- Id of entry in hash search, and value to be returned
1188 -- Pointer into string table
1190 Hash_Index
: Hash_Index_Type
;
1191 -- Computed hash index
1193 Result
: Valid_Name_Id
;
1196 -- Quick handling for one character names
1198 if Buf
.Length
= 1 then
1199 Result
:= First_Name_Id
+ Character'Pos (Buf
.Chars
(1));
1201 -- Otherwise search hash table for existing matching entry
1204 Hash_Index
:= Namet
.Hash
(Buf
);
1205 New_Id
:= Hash_Table
(Hash_Index
);
1207 if New_Id
= No_Name
then
1208 Hash_Table
(Hash_Index
) := Name_Entries
.Last
+ 1;
1213 Integer (Name_Entries
.Table
(New_Id
).Name_Len
)
1218 S
:= Name_Entries
.Table
(New_Id
).Name_Chars_Index
;
1220 for J
in 1 .. Buf
.Length
loop
1221 if Name_Chars
.Table
(S
+ Int
(J
)) /= Buf
.Chars
(J
) then
1229 -- Current entry in hash chain does not match
1232 if Name_Entries
.Table
(New_Id
).Hash_Link
/= No_Name
then
1233 New_Id
:= Name_Entries
.Table
(New_Id
).Hash_Link
;
1235 Name_Entries
.Table
(New_Id
).Hash_Link
:=
1236 Name_Entries
.Last
+ 1;
1242 -- We fall through here only if a matching entry was not found in the
1243 -- hash table. We now create a new entry in the names table. The hash
1244 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1247 ((Name_Chars_Index
=> Name_Chars
.Last
,
1248 Name_Len
=> Short
(Buf
.Length
),
1249 Hash_Link
=> No_Name
,
1252 Name_Has_No_Encodings
=> False,
1253 Boolean1_Info
=> False,
1254 Boolean2_Info
=> False,
1255 Boolean3_Info
=> False,
1258 -- Set corresponding string entry in the Name_Chars table
1260 for J
in 1 .. Buf
.Length
loop
1261 Name_Chars
.Append
(Buf
.Chars
(J
));
1264 Name_Chars
.Append
(ASCII
.NUL
);
1266 Result
:= Name_Entries
.Last
;
1273 function Name_Find
(S
: String) return Valid_Name_Id
is
1274 Buf
: Bounded_String
(Max_Length
=> S
'Length);
1277 return Name_Find
(Buf
);
1284 function Name_Equals
1285 (N1
: Valid_Name_Id
;
1286 N2
: Valid_Name_Id
) return Boolean
1289 return N1
= N2
or else Get_Name_String
(N1
) = Get_Name_String
(N2
);
1296 function Present
(Nam
: File_Name_Type
) return Boolean is
1298 return Nam
/= No_File
;
1305 function Present
(Nam
: Name_Id
) return Boolean is
1307 return Nam
/= No_Name
;
1314 function Present
(Nam
: Unit_Name_Type
) return Boolean is
1316 return Nam
/= No_Unit_Name
;
1323 procedure Reinitialize
is
1328 -- Initialize entries for one character names
1330 for C
in Character loop
1332 ((Name_Chars_Index
=> Name_Chars
.Last
,
1336 Hash_Link
=> No_Name
,
1337 Name_Has_No_Encodings
=> True,
1338 Boolean1_Info
=> False,
1339 Boolean2_Info
=> False,
1340 Boolean3_Info
=> False,
1343 Name_Chars
.Append
(C
);
1344 Name_Chars
.Append
(ASCII
.NUL
);
1349 for J
in Hash_Index_Type
loop
1350 Hash_Table
(J
) := No_Name
;
1354 ----------------------
1355 -- Reset_Name_Table --
1356 ----------------------
1358 procedure Reset_Name_Table
is
1360 for J
in First_Name_Id
.. Name_Entries
.Last
loop
1361 Name_Entries
.Table
(J
).Int_Info
:= 0;
1362 Name_Entries
.Table
(J
).Byte_Info
:= 0;
1364 end Reset_Name_Table
;
1366 --------------------------------
1367 -- Set_Character_Literal_Name --
1368 --------------------------------
1370 procedure Set_Character_Literal_Name
1371 (Buf
: in out Bounded_String
;
1377 Append_Encoded
(Buf
, C
);
1378 end Set_Character_Literal_Name
;
1380 procedure Set_Character_Literal_Name
(C
: Char_Code
) is
1382 Set_Character_Literal_Name
(Global_Name_Buffer
, C
);
1383 end Set_Character_Literal_Name
;
1385 -----------------------------
1386 -- Set_Name_Table_Boolean1 --
1387 -----------------------------
1389 procedure Set_Name_Table_Boolean1
(Id
: Valid_Name_Id
; Val
: Boolean) is
1391 pragma Assert
(Is_Valid_Name
(Id
));
1392 Name_Entries
.Table
(Id
).Boolean1_Info
:= Val
;
1393 end Set_Name_Table_Boolean1
;
1395 -----------------------------
1396 -- Set_Name_Table_Boolean2 --
1397 -----------------------------
1399 procedure Set_Name_Table_Boolean2
(Id
: Valid_Name_Id
; Val
: Boolean) is
1401 pragma Assert
(Is_Valid_Name
(Id
));
1402 Name_Entries
.Table
(Id
).Boolean2_Info
:= Val
;
1403 end Set_Name_Table_Boolean2
;
1405 -----------------------------
1406 -- Set_Name_Table_Boolean3 --
1407 -----------------------------
1409 procedure Set_Name_Table_Boolean3
(Id
: Valid_Name_Id
; Val
: Boolean) is
1411 pragma Assert
(Is_Valid_Name
(Id
));
1412 Name_Entries
.Table
(Id
).Boolean3_Info
:= Val
;
1413 end Set_Name_Table_Boolean3
;
1415 -------------------------
1416 -- Set_Name_Table_Byte --
1417 -------------------------
1419 procedure Set_Name_Table_Byte
(Id
: Valid_Name_Id
; Val
: Byte
) is
1421 pragma Assert
(Is_Valid_Name
(Id
));
1422 Name_Entries
.Table
(Id
).Byte_Info
:= Val
;
1423 end Set_Name_Table_Byte
;
1425 -------------------------
1426 -- Set_Name_Table_Int --
1427 -------------------------
1429 procedure Set_Name_Table_Int
(Id
: Valid_Name_Id
; Val
: Int
) is
1431 pragma Assert
(Is_Valid_Name
(Id
));
1432 Name_Entries
.Table
(Id
).Int_Info
:= Val
;
1433 end Set_Name_Table_Int
;
1435 -----------------------------
1436 -- Store_Encoded_Character --
1437 -----------------------------
1439 procedure Store_Encoded_Character
(C
: Char_Code
) is
1441 Append_Encoded
(Global_Name_Buffer
, C
);
1442 end Store_Encoded_Character
;
1444 --------------------------------------
1445 -- Strip_Qualification_And_Suffixes --
1446 --------------------------------------
1448 procedure Strip_Qualification_And_Suffixes
(Buf
: in out Bounded_String
) is
1452 -- Strip package body qualification string off end
1454 for J
in reverse 2 .. Buf
.Length
loop
1455 if Buf
.Chars
(J
) = 'X' then
1456 Buf
.Length
:= J
- 1;
1460 exit when Buf
.Chars
(J
) not in 'b' |
'n' |
'p';
1463 -- Find rightmost __ or $ separator if one exists. First we position
1464 -- to start the search. If we have a character constant, position
1465 -- just before it, otherwise position to last character but one
1467 if Buf
.Chars
(Buf
.Length
) = ''' then
1468 J
:= Buf
.Length
- 2;
1469 while J
> 0 and then Buf
.Chars
(J
) /= ''' loop
1474 J
:= Buf
.Length
- 1;
1477 -- Loop to search for rightmost __ or $ (homonym) separator
1481 -- If $ separator, homonym separator, so strip it and keep looking
1483 if Buf
.Chars
(J
) = '$' then
1484 Buf
.Length
:= J
- 1;
1485 J
:= Buf
.Length
- 1;
1487 -- Else check for __ found
1489 elsif Buf
.Chars
(J
) = '_' and then Buf
.Chars
(J
+ 1) = '_' then
1491 -- Found __ so see if digit follows, and if so, this is a
1492 -- homonym separator, so strip it and keep looking.
1494 if Buf
.Chars
(J
+ 2) in '0' .. '9' then
1495 Buf
.Length
:= J
- 1;
1496 J
:= Buf
.Length
- 1;
1498 -- If not a homonym separator, then we simply strip the
1499 -- separator and everything that precedes it, and we are done
1502 Buf
.Chars
(1 .. Buf
.Length
- J
- 1) :=
1503 Buf
.Chars
(J
+ 2 .. Buf
.Length
);
1504 Buf
.Length
:= Buf
.Length
- J
- 1;
1512 end Strip_Qualification_And_Suffixes
;
1518 function To_String
(Buf
: Bounded_String
) return String is
1520 return Buf
.Chars
(1 .. Buf
.Length
);
1529 Name_Chars
.Locked
:= False;
1530 Name_Chars
.Set_Last
(Name_Chars
.Last
- Name_Chars_Reserve
);
1532 Name_Entries
.Locked
:= False;
1533 Name_Entries
.Set_Last
(Name_Entries
.Last
- Name_Entries_Reserve
);
1534 Name_Entries
.Release
;
1541 procedure wn
(Id
: Name_Id
) is
1543 Write_Name_For_Debug
(Id
);
1551 procedure Write_Name
(Id
: Valid_Name_Id
) is
1552 Buf
: Bounded_String
(Max_Length
=> Natural (Length_Of_Name
(Id
)));
1555 Write_Str
(Buf
.Chars
(1 .. Buf
.Length
));
1558 ------------------------
1559 -- Write_Name_Decoded --
1560 ------------------------
1562 procedure Write_Name_Decoded
(Id
: Valid_Name_Id
) is
1563 Buf
: Bounded_String
;
1565 Append_Decoded
(Buf
, Id
);
1566 Write_Str
(Buf
.Chars
(1 .. Buf
.Length
));
1567 end Write_Name_Decoded
;
1569 --------------------------
1570 -- Write_Name_For_Debug --
1571 --------------------------
1573 procedure Write_Name_For_Debug
(Id
: Name_Id
; Quote
: String := "") is
1575 if Is_Valid_Name
(Id
) then
1579 Buf
: Bounded_String
(Max_Length
=> Natural (Length_Of_Name
(Id
)));
1582 Write_Str
(Buf
.Chars
(1 .. Buf
.Length
));
1587 elsif Id
= No_Name
then
1588 Write_Str
("<No_Name>");
1590 elsif Id
= Error_Name
then
1591 Write_Str
("<Error_Name>");
1594 Write_Str
("<invalid name ");
1595 Write_Int
(Int
(Id
));
1598 end Write_Name_For_Debug
;
1600 -- Package initialization, initialize tables