File : namet.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- N A M E T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
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.
35
36 with Debug; use Debug;
37 with Opt; use Opt;
38 with Output; use Output;
39 with Tree_IO; use Tree_IO;
40 with Widechar; use Widechar;
41
42 with Interfaces; use Interfaces;
43
44 package body Namet is
45
46 Name_Chars_Reserve : constant := 5000;
47 Name_Entries_Reserve : constant := 100;
48 -- The names table is locked during gigi processing, since gigi assumes
49 -- that the table does not move. After returning from gigi, the names
50 -- table is unlocked again, since writing library file information needs
51 -- to generate some extra names. To avoid the inefficiency of always
52 -- reallocating during this second unlocked phase, we reserve a bit of
53 -- extra space before doing the release call.
54
55 Hash_Num : constant Int := 2**16;
56 -- Number of headers in the hash table. Current hash algorithm is closely
57 -- tailored to this choice, so it can only be changed if a corresponding
58 -- change is made to the hash algorithm.
59
60 Hash_Max : constant Int := Hash_Num - 1;
61 -- Indexes in the hash header table run from 0 to Hash_Num - 1
62
63 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
64 -- Range of hash index values
65
66 Hash_Table : array (Hash_Index_Type) of Name_Id;
67 -- The hash table is used to locate existing entries in the names table.
68 -- The entries point to the first names table entry whose hash value
69 -- matches the hash code. Then subsequent names table entries with the
70 -- same hash code value are linked through the Hash_Link fields.
71
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
75
76 function Hash (Buf : Bounded_String) return Hash_Index_Type;
77 pragma Inline (Hash);
78 -- Compute hash code for name stored in Buf
79
80 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String);
81 -- Given an encoded entity name in Buf, remove package body
82 -- suffix as described for Strip_Package_Body_Suffix, and also remove
83 -- all qualification, i.e. names followed by two underscores.
84
85 -----------------------------
86 -- Add_Char_To_Name_Buffer --
87 -----------------------------
88
89 procedure Add_Char_To_Name_Buffer (C : Character) is
90 begin
91 Append (Global_Name_Buffer, C);
92 end Add_Char_To_Name_Buffer;
93
94 ----------------------------
95 -- Add_Nat_To_Name_Buffer --
96 ----------------------------
97
98 procedure Add_Nat_To_Name_Buffer (V : Nat) is
99 begin
100 Append (Global_Name_Buffer, V);
101 end Add_Nat_To_Name_Buffer;
102
103 ----------------------------
104 -- Add_Str_To_Name_Buffer --
105 ----------------------------
106
107 procedure Add_Str_To_Name_Buffer (S : String) is
108 begin
109 Append (Global_Name_Buffer, S);
110 end Add_Str_To_Name_Buffer;
111
112 ------------
113 -- Append --
114 ------------
115
116 procedure Append (Buf : in out Bounded_String; C : Character) is
117 begin
118 if Buf.Length < Buf.Chars'Last then
119 Buf.Length := Buf.Length + 1;
120 Buf.Chars (Buf.Length) := C;
121 end if;
122 end Append;
123
124 procedure Append (Buf : in out Bounded_String; V : Nat) is
125 begin
126 if V >= 10 then
127 Append (Buf, V / 10);
128 end if;
129
130 Append (Buf, Character'Val (Character'Pos ('0') + V rem 10));
131 end Append;
132
133 procedure Append (Buf : in out Bounded_String; S : String) is
134 begin
135 for J in S'Range loop
136 Append (Buf, S (J));
137 end loop;
138 end Append;
139
140 procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is
141 begin
142 Append (Buf, Buf2.Chars (1 .. Buf2.Length));
143 end Append;
144
145 procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
146 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
147 S : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
148
149 begin
150 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
151 Append (Buf, Name_Chars.Table (S + Int (J)));
152 end loop;
153 end Append;
154
155 --------------------
156 -- Append_Decoded --
157 --------------------
158
159 procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is
160 C : Character;
161 P : Natural;
162 Temp : Bounded_String;
163
164 begin
165 Append (Temp, Id);
166
167 -- Skip scan if we already know there are no encodings
168
169 if Name_Entries.Table (Id).Name_Has_No_Encodings then
170 goto Done;
171 end if;
172
173 -- Quick loop to see if there is anything special to do
174
175 P := 1;
176 loop
177 if P = Temp.Length then
178 Name_Entries.Table (Id).Name_Has_No_Encodings := True;
179 goto Done;
180
181 else
182 C := Temp.Chars (P);
183
184 exit when
185 C = 'U' or else
186 C = 'W' or else
187 C = 'Q' or else
188 C = 'O';
189
190 P := P + 1;
191 end if;
192 end loop;
193
194 -- Here we have at least some encoding that we must decode
195
196 Decode : declare
197 New_Len : Natural;
198 Old : Positive;
199 New_Buf : String (1 .. Temp.Chars'Last);
200
201 procedure Copy_One_Character;
202 -- Copy a character from Temp.Chars to New_Buf. Includes case
203 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
204
205 function Hex (N : Natural) return Word;
206 -- Scans past N digits using Old pointer and returns hex value
207
208 procedure Insert_Character (C : Character);
209 -- Insert a new character into output decoded name
210
211 ------------------------
212 -- Copy_One_Character --
213 ------------------------
214
215 procedure Copy_One_Character is
216 C : Character;
217
218 begin
219 C := Temp.Chars (Old);
220
221 -- U (upper half insertion case)
222
223 if C = 'U'
224 and then Old < Temp.Length
225 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
226 and then Temp.Chars (Old + 1) /= '_'
227 then
228 Old := Old + 1;
229
230 -- If we have upper half encoding, then we have to set an
231 -- appropriate wide character sequence for this character.
232
233 if Upper_Half_Encoding then
234 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
235
236 -- For other encoding methods, upper half characters can
237 -- simply use their normal representation.
238
239 else
240 Insert_Character (Character'Val (Hex (2)));
241 end if;
242
243 -- WW (wide wide character insertion)
244
245 elsif C = 'W'
246 and then Old < Temp.Length
247 and then Temp.Chars (Old + 1) = 'W'
248 then
249 Old := Old + 2;
250 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
251
252 -- W (wide character insertion)
253
254 elsif C = 'W'
255 and then Old < Temp.Length
256 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
257 and then Temp.Chars (Old + 1) /= '_'
258 then
259 Old := Old + 1;
260 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
261
262 -- Any other character is copied unchanged
263
264 else
265 Insert_Character (C);
266 Old := Old + 1;
267 end if;
268 end Copy_One_Character;
269
270 ---------
271 -- Hex --
272 ---------
273
274 function Hex (N : Natural) return Word is
275 T : Word := 0;
276 C : Character;
277
278 begin
279 for J in 1 .. N loop
280 C := Temp.Chars (Old);
281 Old := Old + 1;
282
283 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
284
285 if C <= '9' then
286 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
287 else -- C in 'a' .. 'f'
288 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
289 end if;
290 end loop;
291
292 return T;
293 end Hex;
294
295 ----------------------
296 -- Insert_Character --
297 ----------------------
298
299 procedure Insert_Character (C : Character) is
300 begin
301 New_Len := New_Len + 1;
302 New_Buf (New_Len) := C;
303 end Insert_Character;
304
305 -- Start of processing for Decode
306
307 begin
308 New_Len := 0;
309 Old := 1;
310
311 -- Loop through characters of name
312
313 while Old <= Temp.Length loop
314
315 -- Case of character literal, put apostrophes around character
316
317 if Temp.Chars (Old) = 'Q'
318 and then Old < Temp.Length
319 then
320 Old := Old + 1;
321 Insert_Character (''');
322 Copy_One_Character;
323 Insert_Character (''');
324
325 -- Case of operator name
326
327 elsif Temp.Chars (Old) = 'O'
328 and then Old < Temp.Length
329 and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
330 and then Temp.Chars (Old + 1) /= '_'
331 then
332 Old := Old + 1;
333
334 declare
335 -- This table maps the 2nd and 3rd characters of the name
336 -- into the required output. Two blanks means leave the
337 -- name alone
338
339 Map : constant String :=
340 "ab " & -- Oabs => "abs"
341 "ad+ " & -- Oadd => "+"
342 "an " & -- Oand => "and"
343 "co& " & -- Oconcat => "&"
344 "di/ " & -- Odivide => "/"
345 "eq= " & -- Oeq => "="
346 "ex**" & -- Oexpon => "**"
347 "gt> " & -- Ogt => ">"
348 "ge>=" & -- Oge => ">="
349 "le<=" & -- Ole => "<="
350 "lt< " & -- Olt => "<"
351 "mo " & -- Omod => "mod"
352 "mu* " & -- Omutliply => "*"
353 "ne/=" & -- One => "/="
354 "no " & -- Onot => "not"
355 "or " & -- Oor => "or"
356 "re " & -- Orem => "rem"
357 "su- " & -- Osubtract => "-"
358 "xo "; -- Oxor => "xor"
359
360 J : Integer;
361
362 begin
363 Insert_Character ('"');
364
365 -- Search the map. Note that this loop must terminate, if
366 -- not we have some kind of internal error, and a constraint
367 -- error may be raised.
368
369 J := Map'First;
370 loop
371 exit when Temp.Chars (Old) = Map (J)
372 and then Temp.Chars (Old + 1) = Map (J + 1);
373 J := J + 4;
374 end loop;
375
376 -- Special operator name
377
378 if Map (J + 2) /= ' ' then
379 Insert_Character (Map (J + 2));
380
381 if Map (J + 3) /= ' ' then
382 Insert_Character (Map (J + 3));
383 end if;
384
385 Insert_Character ('"');
386
387 -- Skip past original operator name in input
388
389 while Old <= Temp.Length
390 and then Temp.Chars (Old) in 'a' .. 'z'
391 loop
392 Old := Old + 1;
393 end loop;
394
395 -- For other operator names, leave them in lower case,
396 -- surrounded by apostrophes
397
398 else
399 -- Copy original operator name from input to output
400
401 while Old <= Temp.Length
402 and then Temp.Chars (Old) in 'a' .. 'z'
403 loop
404 Copy_One_Character;
405 end loop;
406
407 Insert_Character ('"');
408 end if;
409 end;
410
411 -- Else copy one character and keep going
412
413 else
414 Copy_One_Character;
415 end if;
416 end loop;
417
418 -- Copy new buffer as result
419
420 Temp.Length := New_Len;
421 Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
422 end Decode;
423
424 <<Done>>
425 Append (Buf, Temp);
426 end Append_Decoded;
427
428 ----------------------------------
429 -- Append_Decoded_With_Brackets --
430 ----------------------------------
431
432 procedure Append_Decoded_With_Brackets
433 (Buf : in out Bounded_String;
434 Id : Name_Id)
435 is
436 P : Natural;
437
438 begin
439 -- Case of operator name, normal decoding is fine
440
441 if Buf.Chars (1) = 'O' then
442 Append_Decoded (Buf, Id);
443
444 -- For character literals, normal decoding is fine
445
446 elsif Buf.Chars (1) = 'Q' then
447 Append_Decoded (Buf, Id);
448
449 -- Only remaining issue is U/W/WW sequences
450
451 else
452 declare
453 Temp : Bounded_String;
454 begin
455 Append (Temp, Id);
456
457 P := 1;
458 while P < Temp.Length loop
459 if Temp.Chars (P + 1) in 'A' .. 'Z' then
460 P := P + 1;
461
462 -- Uhh encoding
463
464 elsif Temp.Chars (P) = 'U' then
465 for J in reverse P + 3 .. P + Temp.Length loop
466 Temp.Chars (J + 3) := Temp.Chars (J);
467 end loop;
468
469 Temp.Length := Temp.Length + 3;
470 Temp.Chars (P + 3) := Temp.Chars (P + 2);
471 Temp.Chars (P + 2) := Temp.Chars (P + 1);
472 Temp.Chars (P) := '[';
473 Temp.Chars (P + 1) := '"';
474 Temp.Chars (P + 4) := '"';
475 Temp.Chars (P + 5) := ']';
476 P := P + 6;
477
478 -- WWhhhhhhhh encoding
479
480 elsif Temp.Chars (P) = 'W'
481 and then P + 9 <= Temp.Length
482 and then Temp.Chars (P + 1) = 'W'
483 and then Temp.Chars (P + 2) not in 'A' .. 'Z'
484 and then Temp.Chars (P + 2) /= '_'
485 then
486 Temp.Chars (P + 12 .. Temp.Length + 2) :=
487 Temp.Chars (P + 10 .. Temp.Length);
488 Temp.Chars (P) := '[';
489 Temp.Chars (P + 1) := '"';
490 Temp.Chars (P + 10) := '"';
491 Temp.Chars (P + 11) := ']';
492 Temp.Length := Temp.Length + 2;
493 P := P + 12;
494
495 -- Whhhh encoding
496
497 elsif Temp.Chars (P) = 'W'
498 and then P < Temp.Length
499 and then Temp.Chars (P + 1) not in 'A' .. 'Z'
500 and then Temp.Chars (P + 1) /= '_'
501 then
502 Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
503 Temp.Chars (P + 5 .. Temp.Length);
504 Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4);
505 Temp.Chars (P) := '[';
506 Temp.Chars (P + 1) := '"';
507 Temp.Chars (P + 6) := '"';
508 Temp.Chars (P + 7) := ']';
509 Temp.Length := Temp.Length + 3;
510 P := P + 8;
511
512 else
513 P := P + 1;
514 end if;
515 end loop;
516
517 Append (Buf, Temp);
518 end;
519 end if;
520 end Append_Decoded_With_Brackets;
521
522 --------------------
523 -- Append_Encoded --
524 --------------------
525
526 procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is
527 procedure Set_Hex_Chars (C : Char_Code);
528 -- Stores given value, which is in the range 0 .. 255, as two hex
529 -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length.
530
531 -------------------
532 -- Set_Hex_Chars --
533 -------------------
534
535 procedure Set_Hex_Chars (C : Char_Code) is
536 Hexd : constant String := "0123456789abcdef";
537 N : constant Natural := Natural (C);
538 begin
539 Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1);
540 Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1);
541 Buf.Length := Buf.Length + 2;
542 end Set_Hex_Chars;
543
544 -- Start of processing for Append_Encoded
545
546 begin
547 Buf.Length := Buf.Length + 1;
548
549 if In_Character_Range (C) then
550 declare
551 CC : constant Character := Get_Character (C);
552 begin
553 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
554 Buf.Chars (Buf.Length) := CC;
555 else
556 Buf.Chars (Buf.Length) := 'U';
557 Set_Hex_Chars (C);
558 end if;
559 end;
560
561 elsif In_Wide_Character_Range (C) then
562 Buf.Chars (Buf.Length) := 'W';
563 Set_Hex_Chars (C / 256);
564 Set_Hex_Chars (C mod 256);
565
566 else
567 Buf.Chars (Buf.Length) := 'W';
568 Buf.Length := Buf.Length + 1;
569 Buf.Chars (Buf.Length) := 'W';
570 Set_Hex_Chars (C / 2 ** 24);
571 Set_Hex_Chars ((C / 2 ** 16) mod 256);
572 Set_Hex_Chars ((C / 256) mod 256);
573 Set_Hex_Chars (C mod 256);
574 end if;
575 end Append_Encoded;
576
577 ------------------------
578 -- Append_Unqualified --
579 ------------------------
580
581 procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is
582 Temp : Bounded_String;
583 begin
584 Append (Temp, Id);
585 Strip_Qualification_And_Suffixes (Temp);
586 Append (Buf, Temp);
587 end Append_Unqualified;
588
589 --------------------------------
590 -- Append_Unqualified_Decoded --
591 --------------------------------
592
593 procedure Append_Unqualified_Decoded
594 (Buf : in out Bounded_String;
595 Id : Name_Id)
596 is
597 Temp : Bounded_String;
598 begin
599 Append_Decoded (Temp, Id);
600 Strip_Qualification_And_Suffixes (Temp);
601 Append (Buf, Temp);
602 end Append_Unqualified_Decoded;
603
604 --------------
605 -- Finalize --
606 --------------
607
608 procedure Finalize is
609 F : array (Int range 0 .. 50) of Int;
610 -- N'th entry is the number of chains of length N, except last entry,
611 -- which is the number of chains of length F'Last or more.
612
613 Max_Chain_Length : Nat := 0;
614 -- Maximum length of all chains
615
616 Probes : Nat := 0;
617 -- Used to compute average number of probes
618
619 Nsyms : Nat := 0;
620 -- Number of symbols in table
621
622 Verbosity : constant Int range 1 .. 3 := 1;
623 pragma Warnings (Off, Verbosity);
624 -- This constant indicates the level of verbosity in the output from
625 -- this procedure. Currently this can only be changed by editing the
626 -- declaration above and recompiling. That's good enough in practice,
627 -- since we very rarely need to use this debug option. Settings are:
628 --
629 -- 1 => print basic summary information
630 -- 2 => in addition print number of entries per hash chain
631 -- 3 => in addition print content of entries
632
633 Zero : constant Int := Character'Pos ('0');
634
635 begin
636 if not Debug_Flag_H then
637 return;
638 end if;
639
640 for J in F'Range loop
641 F (J) := 0;
642 end loop;
643
644 for J in Hash_Index_Type loop
645 if Hash_Table (J) = No_Name then
646 F (0) := F (0) + 1;
647
648 else
649 declare
650 C : Nat;
651 N : Name_Id;
652 S : Int;
653
654 begin
655 C := 0;
656 N := Hash_Table (J);
657
658 while N /= No_Name loop
659 N := Name_Entries.Table (N).Hash_Link;
660 C := C + 1;
661 end loop;
662
663 Nsyms := Nsyms + 1;
664 Probes := Probes + (1 + C) * 100;
665
666 if C > Max_Chain_Length then
667 Max_Chain_Length := C;
668 end if;
669
670 if Verbosity >= 2 then
671 Write_Str ("Hash_Table (");
672 Write_Int (J);
673 Write_Str (") has ");
674 Write_Int (C);
675 Write_Str (" entries");
676 Write_Eol;
677 end if;
678
679 if C < F'Last then
680 F (C) := F (C) + 1;
681 else
682 F (F'Last) := F (F'Last) + 1;
683 end if;
684
685 if Verbosity >= 3 then
686 N := Hash_Table (J);
687 while N /= No_Name loop
688 S := Name_Entries.Table (N).Name_Chars_Index;
689
690 Write_Str (" ");
691
692 for J in 1 .. Name_Entries.Table (N).Name_Len loop
693 Write_Char (Name_Chars.Table (S + Int (J)));
694 end loop;
695
696 Write_Eol;
697
698 N := Name_Entries.Table (N).Hash_Link;
699 end loop;
700 end if;
701 end;
702 end if;
703 end loop;
704
705 Write_Eol;
706
707 for J in F'Range loop
708 if F (J) /= 0 then
709 Write_Str ("Number of hash chains of length ");
710
711 if J < 10 then
712 Write_Char (' ');
713 end if;
714
715 Write_Int (J);
716
717 if J = F'Last then
718 Write_Str (" or greater");
719 end if;
720
721 Write_Str (" = ");
722 Write_Int (F (J));
723 Write_Eol;
724 end if;
725 end loop;
726
727 -- Print out average number of probes, in the case where Name_Find is
728 -- called for a string that is already in the table.
729
730 Write_Eol;
731 Write_Str ("Average number of probes for lookup = ");
732 Probes := Probes / Nsyms;
733 Write_Int (Probes / 200);
734 Write_Char ('.');
735 Probes := (Probes mod 200) / 2;
736 Write_Char (Character'Val (Zero + Probes / 10));
737 Write_Char (Character'Val (Zero + Probes mod 10));
738 Write_Eol;
739
740 Write_Str ("Max_Chain_Length = ");
741 Write_Int (Max_Chain_Length);
742 Write_Eol;
743 Write_Str ("Name_Chars'Length = ");
744 Write_Int (Name_Chars.Last - Name_Chars.First + 1);
745 Write_Eol;
746 Write_Str ("Name_Entries'Length = ");
747 Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
748 Write_Eol;
749 Write_Str ("Nsyms = ");
750 Write_Int (Nsyms);
751 Write_Eol;
752 end Finalize;
753
754 -----------------------------
755 -- Get_Decoded_Name_String --
756 -----------------------------
757
758 procedure Get_Decoded_Name_String (Id : Name_Id) is
759 begin
760 Global_Name_Buffer.Length := 0;
761 Append_Decoded (Global_Name_Buffer, Id);
762 end Get_Decoded_Name_String;
763
764 -------------------------------------------
765 -- Get_Decoded_Name_String_With_Brackets --
766 -------------------------------------------
767
768 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
769 begin
770 Global_Name_Buffer.Length := 0;
771 Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
772 end Get_Decoded_Name_String_With_Brackets;
773
774 ------------------------
775 -- Get_Last_Two_Chars --
776 ------------------------
777
778 procedure Get_Last_Two_Chars
779 (N : Name_Id;
780 C1 : out Character;
781 C2 : out Character)
782 is
783 NE : Name_Entry renames Name_Entries.Table (N);
784 NEL : constant Int := Int (NE.Name_Len);
785
786 begin
787 if NEL >= 2 then
788 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
789 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
790 else
791 C1 := ASCII.NUL;
792 C2 := ASCII.NUL;
793 end if;
794 end Get_Last_Two_Chars;
795
796 ---------------------
797 -- Get_Name_String --
798 ---------------------
799
800 procedure Get_Name_String (Id : Name_Id) is
801 begin
802 Global_Name_Buffer.Length := 0;
803 Append (Global_Name_Buffer, Id);
804 end Get_Name_String;
805
806 function Get_Name_String (Id : Name_Id) return String is
807 Buf : Bounded_String;
808 begin
809 Append (Buf, Id);
810 return +Buf;
811 end Get_Name_String;
812
813 --------------------------------
814 -- Get_Name_String_And_Append --
815 --------------------------------
816
817 procedure Get_Name_String_And_Append (Id : Name_Id) is
818 begin
819 Append (Global_Name_Buffer, Id);
820 end Get_Name_String_And_Append;
821
822 -----------------------------
823 -- Get_Name_Table_Boolean1 --
824 -----------------------------
825
826 function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is
827 begin
828 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
829 return Name_Entries.Table (Id).Boolean1_Info;
830 end Get_Name_Table_Boolean1;
831
832 -----------------------------
833 -- Get_Name_Table_Boolean2 --
834 -----------------------------
835
836 function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is
837 begin
838 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
839 return Name_Entries.Table (Id).Boolean2_Info;
840 end Get_Name_Table_Boolean2;
841
842 -----------------------------
843 -- Get_Name_Table_Boolean3 --
844 -----------------------------
845
846 function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is
847 begin
848 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
849 return Name_Entries.Table (Id).Boolean3_Info;
850 end Get_Name_Table_Boolean3;
851
852 -------------------------
853 -- Get_Name_Table_Byte --
854 -------------------------
855
856 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
857 begin
858 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
859 return Name_Entries.Table (Id).Byte_Info;
860 end Get_Name_Table_Byte;
861
862 -------------------------
863 -- Get_Name_Table_Int --
864 -------------------------
865
866 function Get_Name_Table_Int (Id : Name_Id) return Int is
867 begin
868 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
869 return Name_Entries.Table (Id).Int_Info;
870 end Get_Name_Table_Int;
871
872 -----------------------------------------
873 -- Get_Unqualified_Decoded_Name_String --
874 -----------------------------------------
875
876 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
877 begin
878 Global_Name_Buffer.Length := 0;
879 Append_Unqualified_Decoded (Global_Name_Buffer, Id);
880 end Get_Unqualified_Decoded_Name_String;
881
882 ---------------------------------
883 -- Get_Unqualified_Name_String --
884 ---------------------------------
885
886 procedure Get_Unqualified_Name_String (Id : Name_Id) is
887 begin
888 Global_Name_Buffer.Length := 0;
889 Append_Unqualified (Global_Name_Buffer, Id);
890 end Get_Unqualified_Name_String;
891
892 ----------
893 -- Hash --
894 ----------
895
896 function Hash (Buf : Bounded_String) return Hash_Index_Type is
897
898 -- This hash function looks at every character, in order to make it
899 -- likely that similar strings get different hash values. The rotate by
900 -- 7 bits has been determined empirically to be good, and it doesn't
901 -- lose bits like a shift would. The final conversion can't overflow,
902 -- because the table is 2**16 in size. This function probably needs to
903 -- be changed if the hash table size is changed.
904
905 -- Note that we could get some speed improvement by aligning the string
906 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement
907 -- a growable table. It doesn't seem worth the trouble to do those
908 -- things, for now.
909
910 Result : Unsigned_16 := 0;
911
912 begin
913 for J in 1 .. Buf.Length loop
914 Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J));
915 end loop;
916
917 return Hash_Index_Type (Result);
918 end Hash;
919
920 ----------------
921 -- Initialize --
922 ----------------
923
924 procedure Initialize is
925 begin
926 null;
927 end Initialize;
928
929 ----------------
930 -- Insert_Str --
931 ----------------
932
933 procedure Insert_Str
934 (Buf : in out Bounded_String;
935 S : String;
936 Index : Positive)
937 is
938 SL : constant Natural := S'Length;
939
940 begin
941 Buf.Chars (Index + SL .. Buf.Length + SL) :=
942 Buf.Chars (Index .. Buf.Length);
943 Buf.Chars (Index .. Index + SL - 1) := S;
944 Buf.Length := Buf.Length + SL;
945 end Insert_Str;
946
947 -------------------------------
948 -- Insert_Str_In_Name_Buffer --
949 -------------------------------
950
951 procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
952 begin
953 Insert_Str (Global_Name_Buffer, S, Index);
954 end Insert_Str_In_Name_Buffer;
955
956 ----------------------
957 -- Is_Internal_Name --
958 ----------------------
959
960 function Is_Internal_Name (Buf : Bounded_String) return Boolean is
961 J : Natural;
962
963 begin
964 -- Any name starting or ending with underscore is internal
965
966 if Buf.Chars (1) = '_'
967 or else Buf.Chars (Buf.Length) = '_'
968 then
969 return True;
970
971 -- Allow quoted character
972
973 elsif Buf.Chars (1) = ''' then
974 return False;
975
976 -- All other cases, scan name
977
978 else
979 -- Test backwards, because we only want to test the last entity
980 -- name if the name we have is qualified with other entities.
981
982 J := Buf.Length;
983 while J /= 0 loop
984
985 -- Skip stuff between brackets (A-F OK there)
986
987 if Buf.Chars (J) = ']' then
988 loop
989 J := J - 1;
990 exit when J = 1 or else Buf.Chars (J) = '[';
991 end loop;
992
993 -- Test for internal letter
994
995 elsif Is_OK_Internal_Letter (Buf.Chars (J)) then
996 return True;
997
998 -- Quit if we come to terminating double underscore (note that
999 -- if the current character is an underscore, we know that
1000 -- there is a previous character present, since we already
1001 -- filtered out the case of Buf.Chars (1) = '_' above.
1002
1003 elsif Buf.Chars (J) = '_'
1004 and then Buf.Chars (J - 1) = '_'
1005 and then Buf.Chars (J - 2) /= '_'
1006 then
1007 return False;
1008 end if;
1009
1010 J := J - 1;
1011 end loop;
1012 end if;
1013
1014 return False;
1015 end Is_Internal_Name;
1016
1017 function Is_Internal_Name (Id : Name_Id) return Boolean is
1018 Buf : Bounded_String;
1019 begin
1020 if Id in Error_Name_Or_No_Name then
1021 return False;
1022 else
1023 Append (Buf, Id);
1024 return Is_Internal_Name (Buf);
1025 end if;
1026 end Is_Internal_Name;
1027
1028 function Is_Internal_Name return Boolean is
1029 begin
1030 return Is_Internal_Name (Global_Name_Buffer);
1031 end Is_Internal_Name;
1032
1033 ---------------------------
1034 -- Is_OK_Internal_Letter --
1035 ---------------------------
1036
1037 function Is_OK_Internal_Letter (C : Character) return Boolean is
1038 begin
1039 return C in 'A' .. 'Z'
1040 and then C /= 'O'
1041 and then C /= 'Q'
1042 and then C /= 'U'
1043 and then C /= 'W'
1044 and then C /= 'X';
1045 end Is_OK_Internal_Letter;
1046
1047 ----------------------
1048 -- Is_Operator_Name --
1049 ----------------------
1050
1051 function Is_Operator_Name (Id : Name_Id) return Boolean is
1052 S : Int;
1053 begin
1054 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1055 S := Name_Entries.Table (Id).Name_Chars_Index;
1056 return Name_Chars.Table (S + 1) = 'O';
1057 end Is_Operator_Name;
1058
1059 -------------------
1060 -- Is_Valid_Name --
1061 -------------------
1062
1063 function Is_Valid_Name (Id : Name_Id) return Boolean is
1064 begin
1065 return Id in Name_Entries.First .. Name_Entries.Last;
1066 end Is_Valid_Name;
1067
1068 --------------------
1069 -- Length_Of_Name --
1070 --------------------
1071
1072 function Length_Of_Name (Id : Name_Id) return Nat is
1073 begin
1074 return Int (Name_Entries.Table (Id).Name_Len);
1075 end Length_Of_Name;
1076
1077 ----------
1078 -- Lock --
1079 ----------
1080
1081 procedure Lock is
1082 begin
1083 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
1084 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
1085 Name_Chars.Locked := True;
1086 Name_Entries.Locked := True;
1087 Name_Chars.Release;
1088 Name_Entries.Release;
1089 end Lock;
1090
1091 ------------------------
1092 -- Name_Chars_Address --
1093 ------------------------
1094
1095 function Name_Chars_Address return System.Address is
1096 begin
1097 return Name_Chars.Table (0)'Address;
1098 end Name_Chars_Address;
1099
1100 ----------------
1101 -- Name_Enter --
1102 ----------------
1103
1104 function Name_Enter
1105 (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
1106 is
1107 begin
1108 Name_Entries.Append
1109 ((Name_Chars_Index => Name_Chars.Last,
1110 Name_Len => Short (Buf.Length),
1111 Byte_Info => 0,
1112 Int_Info => 0,
1113 Boolean1_Info => False,
1114 Boolean2_Info => False,
1115 Boolean3_Info => False,
1116 Name_Has_No_Encodings => False,
1117 Hash_Link => No_Name));
1118
1119 -- Set corresponding string entry in the Name_Chars table
1120
1121 for J in 1 .. Buf.Length loop
1122 Name_Chars.Append (Buf.Chars (J));
1123 end loop;
1124
1125 Name_Chars.Append (ASCII.NUL);
1126
1127 return Name_Entries.Last;
1128 end Name_Enter;
1129
1130 --------------------------
1131 -- Name_Entries_Address --
1132 --------------------------
1133
1134 function Name_Entries_Address return System.Address is
1135 begin
1136 return Name_Entries.Table (First_Name_Id)'Address;
1137 end Name_Entries_Address;
1138
1139 ------------------------
1140 -- Name_Entries_Count --
1141 ------------------------
1142
1143 function Name_Entries_Count return Nat is
1144 begin
1145 return Int (Name_Entries.Last - Name_Entries.First + 1);
1146 end Name_Entries_Count;
1147
1148 ---------------
1149 -- Name_Find --
1150 ---------------
1151
1152 function Name_Find
1153 (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
1154 is
1155 New_Id : Name_Id;
1156 -- Id of entry in hash search, and value to be returned
1157
1158 S : Int;
1159 -- Pointer into string table
1160
1161 Hash_Index : Hash_Index_Type;
1162 -- Computed hash index
1163
1164 begin
1165 -- Quick handling for one character names
1166
1167 if Buf.Length = 1 then
1168 return Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
1169
1170 -- Otherwise search hash table for existing matching entry
1171
1172 else
1173 Hash_Index := Namet.Hash (Buf);
1174 New_Id := Hash_Table (Hash_Index);
1175
1176 if New_Id = No_Name then
1177 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1178
1179 else
1180 Search : loop
1181 if Buf.Length /=
1182 Integer (Name_Entries.Table (New_Id).Name_Len)
1183 then
1184 goto No_Match;
1185 end if;
1186
1187 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1188
1189 for J in 1 .. Buf.Length loop
1190 if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then
1191 goto No_Match;
1192 end if;
1193 end loop;
1194
1195 return New_Id;
1196
1197 -- Current entry in hash chain does not match
1198
1199 <<No_Match>>
1200 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1201 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1202 else
1203 Name_Entries.Table (New_Id).Hash_Link :=
1204 Name_Entries.Last + 1;
1205 exit Search;
1206 end if;
1207 end loop Search;
1208 end if;
1209
1210 -- We fall through here only if a matching entry was not found in the
1211 -- hash table. We now create a new entry in the names table. The hash
1212 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1213
1214 Name_Entries.Append
1215 ((Name_Chars_Index => Name_Chars.Last,
1216 Name_Len => Short (Buf.Length),
1217 Hash_Link => No_Name,
1218 Name_Has_No_Encodings => False,
1219 Int_Info => 0,
1220 Byte_Info => 0,
1221 Boolean1_Info => False,
1222 Boolean2_Info => False,
1223 Boolean3_Info => False));
1224
1225 -- Set corresponding string entry in the Name_Chars table
1226
1227 for J in 1 .. Buf.Length loop
1228 Name_Chars.Append (Buf.Chars (J));
1229 end loop;
1230
1231 Name_Chars.Append (ASCII.NUL);
1232
1233 return Name_Entries.Last;
1234 end if;
1235 end Name_Find;
1236
1237 function Name_Find (S : String) return Name_Id is
1238 Buf : Bounded_String;
1239 begin
1240 Append (Buf, S);
1241 return Name_Find (Buf);
1242 end Name_Find;
1243
1244 -------------
1245 -- Nam_In --
1246 -------------
1247
1248 function Nam_In
1249 (T : Name_Id;
1250 V1 : Name_Id;
1251 V2 : Name_Id) return Boolean
1252 is
1253 begin
1254 return T = V1 or else
1255 T = V2;
1256 end Nam_In;
1257
1258 function Nam_In
1259 (T : Name_Id;
1260 V1 : Name_Id;
1261 V2 : Name_Id;
1262 V3 : Name_Id) return Boolean
1263 is
1264 begin
1265 return T = V1 or else
1266 T = V2 or else
1267 T = V3;
1268 end Nam_In;
1269
1270 function Nam_In
1271 (T : Name_Id;
1272 V1 : Name_Id;
1273 V2 : Name_Id;
1274 V3 : Name_Id;
1275 V4 : Name_Id) return Boolean
1276 is
1277 begin
1278 return T = V1 or else
1279 T = V2 or else
1280 T = V3 or else
1281 T = V4;
1282 end Nam_In;
1283
1284 function Nam_In
1285 (T : Name_Id;
1286 V1 : Name_Id;
1287 V2 : Name_Id;
1288 V3 : Name_Id;
1289 V4 : Name_Id;
1290 V5 : Name_Id) return Boolean
1291 is
1292 begin
1293 return T = V1 or else
1294 T = V2 or else
1295 T = V3 or else
1296 T = V4 or else
1297 T = V5;
1298 end Nam_In;
1299
1300 function Nam_In
1301 (T : Name_Id;
1302 V1 : Name_Id;
1303 V2 : Name_Id;
1304 V3 : Name_Id;
1305 V4 : Name_Id;
1306 V5 : Name_Id;
1307 V6 : Name_Id) return Boolean
1308 is
1309 begin
1310 return T = V1 or else
1311 T = V2 or else
1312 T = V3 or else
1313 T = V4 or else
1314 T = V5 or else
1315 T = V6;
1316 end Nam_In;
1317
1318 function Nam_In
1319 (T : Name_Id;
1320 V1 : Name_Id;
1321 V2 : Name_Id;
1322 V3 : Name_Id;
1323 V4 : Name_Id;
1324 V5 : Name_Id;
1325 V6 : Name_Id;
1326 V7 : Name_Id) return Boolean
1327 is
1328 begin
1329 return T = V1 or else
1330 T = V2 or else
1331 T = V3 or else
1332 T = V4 or else
1333 T = V5 or else
1334 T = V6 or else
1335 T = V7;
1336 end Nam_In;
1337
1338 function Nam_In
1339 (T : Name_Id;
1340 V1 : Name_Id;
1341 V2 : Name_Id;
1342 V3 : Name_Id;
1343 V4 : Name_Id;
1344 V5 : Name_Id;
1345 V6 : Name_Id;
1346 V7 : Name_Id;
1347 V8 : Name_Id) return Boolean
1348 is
1349 begin
1350 return T = V1 or else
1351 T = V2 or else
1352 T = V3 or else
1353 T = V4 or else
1354 T = V5 or else
1355 T = V6 or else
1356 T = V7 or else
1357 T = V8;
1358 end Nam_In;
1359
1360 function Nam_In
1361 (T : Name_Id;
1362 V1 : Name_Id;
1363 V2 : Name_Id;
1364 V3 : Name_Id;
1365 V4 : Name_Id;
1366 V5 : Name_Id;
1367 V6 : Name_Id;
1368 V7 : Name_Id;
1369 V8 : Name_Id;
1370 V9 : Name_Id) return Boolean
1371 is
1372 begin
1373 return T = V1 or else
1374 T = V2 or else
1375 T = V3 or else
1376 T = V4 or else
1377 T = V5 or else
1378 T = V6 or else
1379 T = V7 or else
1380 T = V8 or else
1381 T = V9;
1382 end Nam_In;
1383
1384 function Nam_In
1385 (T : Name_Id;
1386 V1 : Name_Id;
1387 V2 : Name_Id;
1388 V3 : Name_Id;
1389 V4 : Name_Id;
1390 V5 : Name_Id;
1391 V6 : Name_Id;
1392 V7 : Name_Id;
1393 V8 : Name_Id;
1394 V9 : Name_Id;
1395 V10 : Name_Id) return Boolean
1396 is
1397 begin
1398 return T = V1 or else
1399 T = V2 or else
1400 T = V3 or else
1401 T = V4 or else
1402 T = V5 or else
1403 T = V6 or else
1404 T = V7 or else
1405 T = V8 or else
1406 T = V9 or else
1407 T = V10;
1408 end Nam_In;
1409
1410 function Nam_In
1411 (T : Name_Id;
1412 V1 : Name_Id;
1413 V2 : Name_Id;
1414 V3 : Name_Id;
1415 V4 : Name_Id;
1416 V5 : Name_Id;
1417 V6 : Name_Id;
1418 V7 : Name_Id;
1419 V8 : Name_Id;
1420 V9 : Name_Id;
1421 V10 : Name_Id;
1422 V11 : Name_Id) return Boolean
1423 is
1424 begin
1425 return T = V1 or else
1426 T = V2 or else
1427 T = V3 or else
1428 T = V4 or else
1429 T = V5 or else
1430 T = V6 or else
1431 T = V7 or else
1432 T = V8 or else
1433 T = V9 or else
1434 T = V10 or else
1435 T = V11;
1436 end Nam_In;
1437
1438 -----------------
1439 -- Name_Equals --
1440 -----------------
1441
1442 function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is
1443 begin
1444 return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
1445 end Name_Equals;
1446
1447 ------------------
1448 -- Reinitialize --
1449 ------------------
1450
1451 procedure Reinitialize is
1452 begin
1453 Name_Chars.Init;
1454 Name_Entries.Init;
1455
1456 -- Initialize entries for one character names
1457
1458 for C in Character loop
1459 Name_Entries.Append
1460 ((Name_Chars_Index => Name_Chars.Last,
1461 Name_Len => 1,
1462 Byte_Info => 0,
1463 Int_Info => 0,
1464 Boolean1_Info => False,
1465 Boolean2_Info => False,
1466 Boolean3_Info => False,
1467 Name_Has_No_Encodings => True,
1468 Hash_Link => No_Name));
1469
1470 Name_Chars.Append (C);
1471 Name_Chars.Append (ASCII.NUL);
1472 end loop;
1473
1474 -- Clear hash table
1475
1476 for J in Hash_Index_Type loop
1477 Hash_Table (J) := No_Name;
1478 end loop;
1479 end Reinitialize;
1480
1481 ----------------------
1482 -- Reset_Name_Table --
1483 ----------------------
1484
1485 procedure Reset_Name_Table is
1486 begin
1487 for J in First_Name_Id .. Name_Entries.Last loop
1488 Name_Entries.Table (J).Int_Info := 0;
1489 Name_Entries.Table (J).Byte_Info := 0;
1490 end loop;
1491 end Reset_Name_Table;
1492
1493 --------------------------------
1494 -- Set_Character_Literal_Name --
1495 --------------------------------
1496
1497 procedure Set_Character_Literal_Name
1498 (Buf : in out Bounded_String;
1499 C : Char_Code)
1500 is
1501 begin
1502 Buf.Length := 0;
1503 Append (Buf, 'Q');
1504 Append_Encoded (Buf, C);
1505 end Set_Character_Literal_Name;
1506
1507 procedure Set_Character_Literal_Name (C : Char_Code) is
1508 begin
1509 Set_Character_Literal_Name (Global_Name_Buffer, C);
1510 end Set_Character_Literal_Name;
1511
1512 -----------------------------
1513 -- Set_Name_Table_Boolean1 --
1514 -----------------------------
1515
1516 procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
1517 begin
1518 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1519 Name_Entries.Table (Id).Boolean1_Info := Val;
1520 end Set_Name_Table_Boolean1;
1521
1522 -----------------------------
1523 -- Set_Name_Table_Boolean2 --
1524 -----------------------------
1525
1526 procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
1527 begin
1528 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1529 Name_Entries.Table (Id).Boolean2_Info := Val;
1530 end Set_Name_Table_Boolean2;
1531
1532 -----------------------------
1533 -- Set_Name_Table_Boolean3 --
1534 -----------------------------
1535
1536 procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
1537 begin
1538 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1539 Name_Entries.Table (Id).Boolean3_Info := Val;
1540 end Set_Name_Table_Boolean3;
1541
1542 -------------------------
1543 -- Set_Name_Table_Byte --
1544 -------------------------
1545
1546 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1547 begin
1548 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1549 Name_Entries.Table (Id).Byte_Info := Val;
1550 end Set_Name_Table_Byte;
1551
1552 -------------------------
1553 -- Set_Name_Table_Int --
1554 -------------------------
1555
1556 procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is
1557 begin
1558 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1559 Name_Entries.Table (Id).Int_Info := Val;
1560 end Set_Name_Table_Int;
1561
1562 -----------------------------
1563 -- Store_Encoded_Character --
1564 -----------------------------
1565
1566 procedure Store_Encoded_Character (C : Char_Code) is
1567 begin
1568 Append_Encoded (Global_Name_Buffer, C);
1569 end Store_Encoded_Character;
1570
1571 --------------------------------------
1572 -- Strip_Qualification_And_Suffixes --
1573 --------------------------------------
1574
1575 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is
1576 J : Integer;
1577
1578 begin
1579 -- Strip package body qualification string off end
1580
1581 for J in reverse 2 .. Buf.Length loop
1582 if Buf.Chars (J) = 'X' then
1583 Buf.Length := J - 1;
1584 exit;
1585 end if;
1586
1587 exit when Buf.Chars (J) /= 'b'
1588 and then Buf.Chars (J) /= 'n'
1589 and then Buf.Chars (J) /= 'p';
1590 end loop;
1591
1592 -- Find rightmost __ or $ separator if one exists. First we position
1593 -- to start the search. If we have a character constant, position
1594 -- just before it, otherwise position to last character but one
1595
1596 if Buf.Chars (Buf.Length) = ''' then
1597 J := Buf.Length - 2;
1598 while J > 0 and then Buf.Chars (J) /= ''' loop
1599 J := J - 1;
1600 end loop;
1601
1602 else
1603 J := Buf.Length - 1;
1604 end if;
1605
1606 -- Loop to search for rightmost __ or $ (homonym) separator
1607
1608 while J > 1 loop
1609
1610 -- If $ separator, homonym separator, so strip it and keep looking
1611
1612 if Buf.Chars (J) = '$' then
1613 Buf.Length := J - 1;
1614 J := Buf.Length - 1;
1615
1616 -- Else check for __ found
1617
1618 elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then
1619
1620 -- Found __ so see if digit follows, and if so, this is a
1621 -- homonym separator, so strip it and keep looking.
1622
1623 if Buf.Chars (J + 2) in '0' .. '9' then
1624 Buf.Length := J - 1;
1625 J := Buf.Length - 1;
1626
1627 -- If not a homonym separator, then we simply strip the
1628 -- separator and everything that precedes it, and we are done
1629
1630 else
1631 Buf.Chars (1 .. Buf.Length - J - 1) :=
1632 Buf.Chars (J + 2 .. Buf.Length);
1633 Buf.Length := Buf.Length - J - 1;
1634 exit;
1635 end if;
1636
1637 else
1638 J := J - 1;
1639 end if;
1640 end loop;
1641 end Strip_Qualification_And_Suffixes;
1642
1643 ---------------
1644 -- To_String --
1645 ---------------
1646
1647 function To_String (Buf : Bounded_String) return String is
1648 begin
1649 return Buf.Chars (1 .. Buf.Length);
1650 end To_String;
1651
1652 ---------------
1653 -- Tree_Read --
1654 ---------------
1655
1656 procedure Tree_Read is
1657 begin
1658 Name_Chars.Tree_Read;
1659 Name_Entries.Tree_Read;
1660
1661 Tree_Read_Data
1662 (Hash_Table'Address,
1663 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1664 end Tree_Read;
1665
1666 ----------------
1667 -- Tree_Write --
1668 ----------------
1669
1670 procedure Tree_Write is
1671 begin
1672 Name_Chars.Tree_Write;
1673 Name_Entries.Tree_Write;
1674
1675 Tree_Write_Data
1676 (Hash_Table'Address,
1677 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1678 end Tree_Write;
1679
1680 ------------
1681 -- Unlock --
1682 ------------
1683
1684 procedure Unlock is
1685 begin
1686 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1687 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1688 Name_Chars.Locked := False;
1689 Name_Entries.Locked := False;
1690 Name_Chars.Release;
1691 Name_Entries.Release;
1692 end Unlock;
1693
1694 --------
1695 -- wn --
1696 --------
1697
1698 procedure wn (Id : Name_Id) is
1699 begin
1700 if Id not in Name_Entries.First .. Name_Entries.Last then
1701 Write_Str ("<invalid name_id>");
1702
1703 elsif Id = No_Name then
1704 Write_Str ("<No_Name>");
1705
1706 elsif Id = Error_Name then
1707 Write_Str ("<Error_Name>");
1708
1709 else
1710 declare
1711 Buf : Bounded_String;
1712 begin
1713 Append (Buf, Id);
1714 Write_Str (Buf.Chars (1 .. Buf.Length));
1715 end;
1716 end if;
1717
1718 Write_Eol;
1719 end wn;
1720
1721 ----------------
1722 -- Write_Name --
1723 ----------------
1724
1725 procedure Write_Name (Id : Name_Id) is
1726 Buf : Bounded_String;
1727 begin
1728 if Id >= First_Name_Id then
1729 Append (Buf, Id);
1730 Write_Str (Buf.Chars (1 .. Buf.Length));
1731 end if;
1732 end Write_Name;
1733
1734 ------------------------
1735 -- Write_Name_Decoded --
1736 ------------------------
1737
1738 procedure Write_Name_Decoded (Id : Name_Id) is
1739 Buf : Bounded_String;
1740 begin
1741 if Id >= First_Name_Id then
1742 Append_Decoded (Buf, Id);
1743 Write_Str (Buf.Chars (1 .. Buf.Length));
1744 end if;
1745 end Write_Name_Decoded;
1746
1747 -- Package initialization, initialize tables
1748
1749 begin
1750 Reinitialize;
1751 end Namet;