Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/namet.adb @ 111:04ced10e8804

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