* arm.c (FL_WBUF): Define.
[official-gcc.git] / gcc / ada / namet.adb
blobb10696dc863915b0308a8700a03481eda15bf45b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- N A M E T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2005 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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 -- WARNING: There is a C version of this package. Any changes to this
35 -- source file must be properly reflected in the C header file a-namet.h
36 -- which is created manually from namet.ads and namet.adb.
38 with Debug; use Debug;
39 with Opt; use Opt;
40 with Output; use Output;
41 with Tree_IO; use Tree_IO;
42 with Widechar; use Widechar;
44 package body Namet is
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.
55 Hash_Num : constant Int := 2**12;
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 alogorithm.
60 Hash_Max : constant Int := Hash_Num - 1;
61 -- Indexes in the hash header table run from 0 to Hash_Num - 1
63 subtype Hash_Index_Type is Int range 0 .. Hash_Max;
64 -- Range of hash index values
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.
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 function Hash return Hash_Index_Type;
77 pragma Inline (Hash);
78 -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
80 procedure Strip_Qualification_And_Suffixes;
81 -- Given an encoded entity name in Name_Buffer, 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. The
84 -- contents of Name_Buffer is modified by this call, and on return
85 -- Name_Buffer and Name_Len reflect the stripped name.
87 -----------------------------
88 -- Add_Char_To_Name_Buffer --
89 -----------------------------
91 procedure Add_Char_To_Name_Buffer (C : Character) is
92 begin
93 if Name_Len < Name_Buffer'Last then
94 Name_Len := Name_Len + 1;
95 Name_Buffer (Name_Len) := C;
96 end if;
97 end Add_Char_To_Name_Buffer;
99 ----------------------------
100 -- Add_Nat_To_Name_Buffer --
101 ----------------------------
103 procedure Add_Nat_To_Name_Buffer (V : Nat) is
104 begin
105 if V >= 10 then
106 Add_Nat_To_Name_Buffer (V / 10);
107 end if;
109 Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
110 end Add_Nat_To_Name_Buffer;
112 ----------------------------
113 -- Add_Str_To_Name_Buffer --
114 ----------------------------
116 procedure Add_Str_To_Name_Buffer (S : String) is
117 begin
118 for J in S'Range loop
119 Add_Char_To_Name_Buffer (S (J));
120 end loop;
121 end Add_Str_To_Name_Buffer;
124 --------------
125 -- Finalize --
126 --------------
128 procedure Finalize is
129 Max_Chain_Length : constant := 50;
130 -- Max length of chains for which specific information is output
132 F : array (Int range 0 .. Max_Chain_Length) of Int;
133 -- N'th entry is number of chains of length N
135 Probes : Int := 0;
136 -- Used to compute average number of probes
138 Nsyms : Int := 0;
139 -- Number of symbols in table
141 begin
142 if Debug_Flag_H then
143 for J in F'Range loop
144 F (J) := 0;
145 end loop;
147 for J in Hash_Index_Type loop
148 if Hash_Table (J) = No_Name then
149 F (0) := F (0) + 1;
151 else
152 Write_Str ("Hash_Table (");
153 Write_Int (Int (J));
154 Write_Str (") has ");
156 declare
157 C : Int := 1;
158 N : Name_Id;
159 S : Int;
161 begin
162 C := 0;
163 N := Hash_Table (J);
165 while N /= No_Name loop
166 N := Name_Entries.Table (N).Hash_Link;
167 C := C + 1;
168 end loop;
170 Write_Int (C);
171 Write_Str (" entries");
172 Write_Eol;
174 if C < Max_Chain_Length then
175 F (C) := F (C) + 1;
176 else
177 F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
178 end if;
180 N := Hash_Table (J);
182 while N /= No_Name loop
183 S := Name_Entries.Table (N).Name_Chars_Index;
184 Write_Str (" ");
186 for J in 1 .. Name_Entries.Table (N).Name_Len loop
187 Write_Char (Name_Chars.Table (S + Int (J)));
188 end loop;
190 Write_Eol;
191 N := Name_Entries.Table (N).Hash_Link;
192 end loop;
193 end;
194 end if;
195 end loop;
197 Write_Eol;
199 for J in Int range 0 .. Max_Chain_Length loop
200 if F (J) /= 0 then
201 Write_Str ("Number of hash chains of length ");
203 if J < 10 then
204 Write_Char (' ');
205 end if;
207 Write_Int (J);
209 if J = Max_Chain_Length then
210 Write_Str (" or greater");
211 end if;
213 Write_Str (" = ");
214 Write_Int (F (J));
215 Write_Eol;
217 if J /= 0 then
218 Nsyms := Nsyms + F (J);
219 Probes := Probes + F (J) * (1 + J) * 100;
220 end if;
221 end if;
222 end loop;
224 Write_Eol;
225 Write_Str ("Average number of probes for lookup = ");
226 Probes := Probes / Nsyms;
227 Write_Int (Probes / 200);
228 Write_Char ('.');
229 Probes := (Probes mod 200) / 2;
230 Write_Char (Character'Val (48 + Probes / 10));
231 Write_Char (Character'Val (48 + Probes mod 10));
232 Write_Eol;
233 Write_Eol;
234 end if;
235 end Finalize;
237 -----------------------------
238 -- Get_Decoded_Name_String --
239 -----------------------------
241 procedure Get_Decoded_Name_String (Id : Name_Id) is
242 C : Character;
243 P : Natural;
245 begin
246 Get_Name_String (Id);
248 -- Quick loop to see if there is anything special to do
250 P := 1;
251 loop
252 if P = Name_Len then
253 return;
255 else
256 C := Name_Buffer (P);
258 exit when
259 C = 'U' or else
260 C = 'W' or else
261 C = 'Q' or else
262 C = 'O';
264 P := P + 1;
265 end if;
266 end loop;
268 -- Here we have at least some encoding that we must decode
270 Decode : declare
271 New_Len : Natural;
272 Old : Positive;
273 New_Buf : String (1 .. Name_Buffer'Last);
275 procedure Copy_One_Character;
276 -- Copy a character from Name_Buffer to New_Buf. Includes case
277 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
279 function Hex (N : Natural) return Word;
280 -- Scans past N digits using Old pointer and returns hex value
282 procedure Insert_Character (C : Character);
283 -- Insert a new character into output decoded name
285 ------------------------
286 -- Copy_One_Character --
287 ------------------------
289 procedure Copy_One_Character is
290 C : Character;
292 begin
293 C := Name_Buffer (Old);
295 -- U (upper half insertion case)
297 if C = 'U'
298 and then Old < Name_Len
299 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
300 and then Name_Buffer (Old + 1) /= '_'
301 then
302 Old := Old + 1;
304 -- If we have upper half encoding, then we have to set an
305 -- appropriate wide character sequence for this character.
307 if Upper_Half_Encoding then
308 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
310 -- For other encoding methods, upper half characters can
311 -- simply use their normal representation.
313 else
314 Insert_Character (Character'Val (Hex (2)));
315 end if;
318 -- WW (wide wide character insertion)
320 elsif C = 'W'
321 and then Old < Name_Len
322 and then Name_Buffer (Old + 1) = 'W'
323 then
324 Old := Old + 2;
325 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
327 -- W (wide character insertion)
329 elsif C = 'W'
330 and then Old < Name_Len
331 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
332 and then Name_Buffer (Old + 1) /= '_'
333 then
334 Old := Old + 1;
335 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
337 -- Any other character is copied unchanged
339 else
340 Insert_Character (C);
341 Old := Old + 1;
342 end if;
343 end Copy_One_Character;
345 ---------
346 -- Hex --
347 ---------
349 function Hex (N : Natural) return Word is
350 T : Word := 0;
351 C : Character;
353 begin
354 for J in 1 .. N loop
355 C := Name_Buffer (Old);
356 Old := Old + 1;
358 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
360 if C <= '9' then
361 T := 16 * T + Character'Pos (C) - Character'Pos ('0');
362 else -- C in 'a' .. 'f'
363 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
364 end if;
365 end loop;
367 return T;
368 end Hex;
370 ----------------------
371 -- Insert_Character --
372 ----------------------
374 procedure Insert_Character (C : Character) is
375 begin
376 New_Len := New_Len + 1;
377 New_Buf (New_Len) := C;
378 end Insert_Character;
380 -- Start of processing for Decode
382 begin
383 New_Len := 0;
384 Old := 1;
386 -- Loop through characters of name
388 while Old <= Name_Len loop
390 -- Case of character literal, put apostrophes around character
392 if Name_Buffer (Old) = 'Q'
393 and then Old < Name_Len
394 then
395 Old := Old + 1;
396 Insert_Character (''');
397 Copy_One_Character;
398 Insert_Character (''');
400 -- Case of operator name
402 elsif Name_Buffer (Old) = 'O'
403 and then Old < Name_Len
404 and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
405 and then Name_Buffer (Old + 1) /= '_'
406 then
407 Old := Old + 1;
409 declare
410 -- This table maps the 2nd and 3rd characters of the name
411 -- into the required output. Two blanks means leave the
412 -- name alone
414 Map : constant String :=
415 "ab " & -- Oabs => "abs"
416 "ad+ " & -- Oadd => "+"
417 "an " & -- Oand => "and"
418 "co& " & -- Oconcat => "&"
419 "di/ " & -- Odivide => "/"
420 "eq= " & -- Oeq => "="
421 "ex**" & -- Oexpon => "**"
422 "gt> " & -- Ogt => ">"
423 "ge>=" & -- Oge => ">="
424 "le<=" & -- Ole => "<="
425 "lt< " & -- Olt => "<"
426 "mo " & -- Omod => "mod"
427 "mu* " & -- Omutliply => "*"
428 "ne/=" & -- One => "/="
429 "no " & -- Onot => "not"
430 "or " & -- Oor => "or"
431 "re " & -- Orem => "rem"
432 "su- " & -- Osubtract => "-"
433 "xo "; -- Oxor => "xor"
435 J : Integer;
437 begin
438 Insert_Character ('"');
440 -- Search the map. Note that this loop must terminate, if
441 -- not we have some kind of internal error, and a constraint
442 -- constraint error may be raised.
444 J := Map'First;
445 loop
446 exit when Name_Buffer (Old) = Map (J)
447 and then Name_Buffer (Old + 1) = Map (J + 1);
448 J := J + 4;
449 end loop;
451 -- Special operator name
453 if Map (J + 2) /= ' ' then
454 Insert_Character (Map (J + 2));
456 if Map (J + 3) /= ' ' then
457 Insert_Character (Map (J + 3));
458 end if;
460 Insert_Character ('"');
462 -- Skip past original operator name in input
464 while Old <= Name_Len
465 and then Name_Buffer (Old) in 'a' .. 'z'
466 loop
467 Old := Old + 1;
468 end loop;
470 -- For other operator names, leave them in lower case,
471 -- surrounded by apostrophes
473 else
474 -- Copy original operator name from input to output
476 while Old <= Name_Len
477 and then Name_Buffer (Old) in 'a' .. 'z'
478 loop
479 Copy_One_Character;
480 end loop;
482 Insert_Character ('"');
483 end if;
484 end;
486 -- Else copy one character and keep going
488 else
489 Copy_One_Character;
490 end if;
491 end loop;
493 -- Copy new buffer as result
495 Name_Len := New_Len;
496 Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
497 end Decode;
498 end Get_Decoded_Name_String;
500 -------------------------------------------
501 -- Get_Decoded_Name_String_With_Brackets --
502 -------------------------------------------
504 procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
505 P : Natural;
507 begin
508 -- Case of operator name, normal decoding is fine
510 if Name_Buffer (1) = 'O' then
511 Get_Decoded_Name_String (Id);
513 -- For character literals, normal decoding is fine
515 elsif Name_Buffer (1) = 'Q' then
516 Get_Decoded_Name_String (Id);
518 -- Only remaining issue is U/W/WW sequences
520 else
521 Get_Name_String (Id);
523 P := 1;
524 while P < Name_Len loop
525 if Name_Buffer (P + 1) in 'A' .. 'Z' then
526 P := P + 1;
528 -- Uhh encoding
530 elsif Name_Buffer (P) = 'U' then
531 for J in reverse P + 3 .. P + Name_Len loop
532 Name_Buffer (J + 3) := Name_Buffer (J);
533 end loop;
535 Name_Len := Name_Len + 3;
536 Name_Buffer (P + 3) := Name_Buffer (P + 2);
537 Name_Buffer (P + 2) := Name_Buffer (P + 1);
538 Name_Buffer (P) := '[';
539 Name_Buffer (P + 1) := '"';
540 Name_Buffer (P + 4) := '"';
541 Name_Buffer (P + 5) := ']';
542 P := P + 6;
544 -- WWhhhhhhhh encoding
546 elsif Name_Buffer (P) = 'W'
547 and then P + 9 <= Name_Len
548 and then Name_Buffer (P + 1) = 'W'
549 and then Name_Buffer (P + 2) not in 'A' .. 'Z'
550 and then Name_Buffer (P + 2) /= '_'
551 then
552 Name_Buffer (P + 12 .. Name_Len + 2) :=
553 Name_Buffer (P + 10 .. Name_Len);
554 Name_Buffer (P) := '[';
555 Name_Buffer (P + 1) := '"';
556 Name_Buffer (P + 10) := '"';
557 Name_Buffer (P + 11) := ']';
558 Name_Len := Name_Len + 2;
559 P := P + 12;
561 -- Whhhh encoding
563 elsif Name_Buffer (P) = 'W'
564 and then P < Name_Len
565 and then Name_Buffer (P + 1) not in 'A' .. 'Z'
566 and then Name_Buffer (P + 1) /= '_'
567 then
568 Name_Buffer (P + 8 .. P + Name_Len + 3) :=
569 Name_Buffer (P + 5 .. Name_Len);
570 Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
571 Name_Buffer (P) := '[';
572 Name_Buffer (P + 1) := '"';
573 Name_Buffer (P + 6) := '"';
574 Name_Buffer (P + 7) := ']';
575 Name_Len := Name_Len + 3;
576 P := P + 8;
578 else
579 P := P + 1;
580 end if;
581 end loop;
582 end if;
583 end Get_Decoded_Name_String_With_Brackets;
585 ------------------------
586 -- Get_Last_Two_Chars --
587 ------------------------
589 procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
590 NE : Name_Entry renames Name_Entries.Table (N);
591 NEL : constant Int := Int (NE.Name_Len);
593 begin
594 if NEL >= 2 then
595 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
596 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
597 else
598 C1 := ASCII.NUL;
599 C2 := ASCII.NUL;
600 end if;
601 end Get_Last_Two_Chars;
603 ---------------------
604 -- Get_Name_String --
605 ---------------------
607 -- Procedure version leaving result in Name_Buffer, length in Name_Len
609 procedure Get_Name_String (Id : Name_Id) is
610 S : Int;
612 begin
613 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
615 S := Name_Entries.Table (Id).Name_Chars_Index;
616 Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
618 for J in 1 .. Name_Len loop
619 Name_Buffer (J) := Name_Chars.Table (S + Int (J));
620 end loop;
621 end Get_Name_String;
623 ---------------------
624 -- Get_Name_String --
625 ---------------------
627 -- Function version returning a string
629 function Get_Name_String (Id : Name_Id) return String is
630 S : Int;
632 begin
633 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
634 S := Name_Entries.Table (Id).Name_Chars_Index;
636 declare
637 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
639 begin
640 for J in R'Range loop
641 R (J) := Name_Chars.Table (S + Int (J));
642 end loop;
644 return R;
645 end;
646 end Get_Name_String;
648 --------------------------------
649 -- Get_Name_String_And_Append --
650 --------------------------------
652 procedure Get_Name_String_And_Append (Id : Name_Id) is
653 S : Int;
655 begin
656 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
658 S := Name_Entries.Table (Id).Name_Chars_Index;
660 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
661 Name_Len := Name_Len + 1;
662 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
663 end loop;
664 end Get_Name_String_And_Append;
666 -------------------------
667 -- Get_Name_Table_Byte --
668 -------------------------
670 function Get_Name_Table_Byte (Id : Name_Id) return Byte is
671 begin
672 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
673 return Name_Entries.Table (Id).Byte_Info;
674 end Get_Name_Table_Byte;
676 -------------------------
677 -- Get_Name_Table_Info --
678 -------------------------
680 function Get_Name_Table_Info (Id : Name_Id) return Int is
681 begin
682 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
683 return Name_Entries.Table (Id).Int_Info;
684 end Get_Name_Table_Info;
686 -----------------------------------------
687 -- Get_Unqualified_Decoded_Name_String --
688 -----------------------------------------
690 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
691 begin
692 Get_Decoded_Name_String (Id);
693 Strip_Qualification_And_Suffixes;
694 end Get_Unqualified_Decoded_Name_String;
696 ---------------------------------
697 -- Get_Unqualified_Name_String --
698 ---------------------------------
700 procedure Get_Unqualified_Name_String (Id : Name_Id) is
701 begin
702 Get_Name_String (Id);
703 Strip_Qualification_And_Suffixes;
704 end Get_Unqualified_Name_String;
706 ----------
707 -- Hash --
708 ----------
710 function Hash return Hash_Index_Type is
711 begin
712 -- For the cases of 1-12 characters, all characters participate in the
713 -- hash. The positioning is randomized, with the bias that characters
714 -- later on participate fully (i.e. are added towards the right side).
716 case Name_Len is
718 when 0 =>
719 return 0;
721 when 1 =>
722 return
723 Character'Pos (Name_Buffer (1));
725 when 2 =>
726 return ((
727 Character'Pos (Name_Buffer (1))) * 64 +
728 Character'Pos (Name_Buffer (2))) mod Hash_Num;
730 when 3 =>
731 return (((
732 Character'Pos (Name_Buffer (1))) * 16 +
733 Character'Pos (Name_Buffer (3))) * 16 +
734 Character'Pos (Name_Buffer (2))) mod Hash_Num;
736 when 4 =>
737 return ((((
738 Character'Pos (Name_Buffer (1))) * 8 +
739 Character'Pos (Name_Buffer (2))) * 8 +
740 Character'Pos (Name_Buffer (3))) * 8 +
741 Character'Pos (Name_Buffer (4))) mod Hash_Num;
743 when 5 =>
744 return (((((
745 Character'Pos (Name_Buffer (4))) * 8 +
746 Character'Pos (Name_Buffer (1))) * 4 +
747 Character'Pos (Name_Buffer (3))) * 4 +
748 Character'Pos (Name_Buffer (5))) * 8 +
749 Character'Pos (Name_Buffer (2))) mod Hash_Num;
751 when 6 =>
752 return ((((((
753 Character'Pos (Name_Buffer (5))) * 4 +
754 Character'Pos (Name_Buffer (1))) * 4 +
755 Character'Pos (Name_Buffer (4))) * 4 +
756 Character'Pos (Name_Buffer (2))) * 4 +
757 Character'Pos (Name_Buffer (6))) * 4 +
758 Character'Pos (Name_Buffer (3))) mod Hash_Num;
760 when 7 =>
761 return (((((((
762 Character'Pos (Name_Buffer (4))) * 4 +
763 Character'Pos (Name_Buffer (3))) * 4 +
764 Character'Pos (Name_Buffer (1))) * 4 +
765 Character'Pos (Name_Buffer (2))) * 2 +
766 Character'Pos (Name_Buffer (5))) * 2 +
767 Character'Pos (Name_Buffer (7))) * 2 +
768 Character'Pos (Name_Buffer (6))) mod Hash_Num;
770 when 8 =>
771 return ((((((((
772 Character'Pos (Name_Buffer (2))) * 4 +
773 Character'Pos (Name_Buffer (1))) * 4 +
774 Character'Pos (Name_Buffer (3))) * 2 +
775 Character'Pos (Name_Buffer (5))) * 2 +
776 Character'Pos (Name_Buffer (7))) * 2 +
777 Character'Pos (Name_Buffer (6))) * 2 +
778 Character'Pos (Name_Buffer (4))) * 2 +
779 Character'Pos (Name_Buffer (8))) mod Hash_Num;
781 when 9 =>
782 return (((((((((
783 Character'Pos (Name_Buffer (2))) * 4 +
784 Character'Pos (Name_Buffer (1))) * 4 +
785 Character'Pos (Name_Buffer (3))) * 4 +
786 Character'Pos (Name_Buffer (4))) * 2 +
787 Character'Pos (Name_Buffer (8))) * 2 +
788 Character'Pos (Name_Buffer (7))) * 2 +
789 Character'Pos (Name_Buffer (5))) * 2 +
790 Character'Pos (Name_Buffer (6))) * 2 +
791 Character'Pos (Name_Buffer (9))) mod Hash_Num;
793 when 10 =>
794 return ((((((((((
795 Character'Pos (Name_Buffer (01))) * 2 +
796 Character'Pos (Name_Buffer (02))) * 2 +
797 Character'Pos (Name_Buffer (08))) * 2 +
798 Character'Pos (Name_Buffer (03))) * 2 +
799 Character'Pos (Name_Buffer (04))) * 2 +
800 Character'Pos (Name_Buffer (09))) * 2 +
801 Character'Pos (Name_Buffer (06))) * 2 +
802 Character'Pos (Name_Buffer (05))) * 2 +
803 Character'Pos (Name_Buffer (07))) * 2 +
804 Character'Pos (Name_Buffer (10))) mod Hash_Num;
806 when 11 =>
807 return (((((((((((
808 Character'Pos (Name_Buffer (05))) * 2 +
809 Character'Pos (Name_Buffer (01))) * 2 +
810 Character'Pos (Name_Buffer (06))) * 2 +
811 Character'Pos (Name_Buffer (09))) * 2 +
812 Character'Pos (Name_Buffer (07))) * 2 +
813 Character'Pos (Name_Buffer (03))) * 2 +
814 Character'Pos (Name_Buffer (08))) * 2 +
815 Character'Pos (Name_Buffer (02))) * 2 +
816 Character'Pos (Name_Buffer (10))) * 2 +
817 Character'Pos (Name_Buffer (04))) * 2 +
818 Character'Pos (Name_Buffer (11))) mod Hash_Num;
820 when 12 =>
821 return ((((((((((((
822 Character'Pos (Name_Buffer (03))) * 2 +
823 Character'Pos (Name_Buffer (02))) * 2 +
824 Character'Pos (Name_Buffer (05))) * 2 +
825 Character'Pos (Name_Buffer (01))) * 2 +
826 Character'Pos (Name_Buffer (06))) * 2 +
827 Character'Pos (Name_Buffer (04))) * 2 +
828 Character'Pos (Name_Buffer (08))) * 2 +
829 Character'Pos (Name_Buffer (11))) * 2 +
830 Character'Pos (Name_Buffer (07))) * 2 +
831 Character'Pos (Name_Buffer (09))) * 2 +
832 Character'Pos (Name_Buffer (10))) * 2 +
833 Character'Pos (Name_Buffer (12))) mod Hash_Num;
835 -- Names longer than 12 characters are handled by taking the first
836 -- 6 odd numbered characters and the last 6 even numbered characters.
838 when others => declare
839 Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
840 begin
841 return ((((((((((((
842 Character'Pos (Name_Buffer (01))) * 2 +
843 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
844 Character'Pos (Name_Buffer (03))) * 2 +
845 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
846 Character'Pos (Name_Buffer (05))) * 2 +
847 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
848 Character'Pos (Name_Buffer (07))) * 2 +
849 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
850 Character'Pos (Name_Buffer (09))) * 2 +
851 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
852 Character'Pos (Name_Buffer (11))) * 2 +
853 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
854 end;
855 end case;
856 end Hash;
858 ----------------
859 -- Initialize --
860 ----------------
862 procedure Initialize is
863 begin
864 Name_Chars.Init;
865 Name_Entries.Init;
867 -- Initialize entries for one character names
869 for C in Character loop
870 Name_Entries.Increment_Last;
871 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
872 Name_Chars.Last;
873 Name_Entries.Table (Name_Entries.Last).Name_Len := 1;
874 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
875 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
876 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
877 Name_Chars.Increment_Last;
878 Name_Chars.Table (Name_Chars.Last) := C;
879 Name_Chars.Increment_Last;
880 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
881 end loop;
883 -- Clear hash table
885 for J in Hash_Index_Type loop
886 Hash_Table (J) := No_Name;
887 end loop;
888 end Initialize;
890 ----------------------
891 -- Is_Internal_Name --
892 ----------------------
894 -- Version taking an argument
896 function Is_Internal_Name (Id : Name_Id) return Boolean is
897 begin
898 Get_Name_String (Id);
899 return Is_Internal_Name;
900 end Is_Internal_Name;
902 ----------------------
903 -- Is_Internal_Name --
904 ----------------------
906 -- Version taking its input from Name_Buffer
908 function Is_Internal_Name return Boolean is
909 begin
910 if Name_Buffer (1) = '_'
911 or else Name_Buffer (Name_Len) = '_'
912 then
913 return True;
915 else
916 -- Test backwards, because we only want to test the last entity
917 -- name if the name we have is qualified with other entities.
919 for J in reverse 1 .. Name_Len loop
920 if Is_OK_Internal_Letter (Name_Buffer (J)) then
921 return True;
923 -- Quit if we come to terminating double underscore (note that
924 -- if the current character is an underscore, we know that
925 -- there is a previous character present, since we already
926 -- filtered out the case of Name_Buffer (1) = '_' above.
928 elsif Name_Buffer (J) = '_'
929 and then Name_Buffer (J - 1) = '_'
930 and then Name_Buffer (J - 2) /= '_'
931 then
932 return False;
933 end if;
934 end loop;
935 end if;
937 return False;
938 end Is_Internal_Name;
940 ---------------------------
941 -- Is_OK_Internal_Letter --
942 ---------------------------
944 function Is_OK_Internal_Letter (C : Character) return Boolean is
945 begin
946 return C in 'A' .. 'Z'
947 and then C /= 'O'
948 and then C /= 'Q'
949 and then C /= 'U'
950 and then C /= 'W'
951 and then C /= 'X';
952 end Is_OK_Internal_Letter;
954 ----------------------
955 -- Is_Operator_Name --
956 ----------------------
958 function Is_Operator_Name (Id : Name_Id) return Boolean is
959 S : Int;
960 begin
961 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
962 S := Name_Entries.Table (Id).Name_Chars_Index;
963 return Name_Chars.Table (S + 1) = 'O';
964 end Is_Operator_Name;
966 --------------------
967 -- Length_Of_Name --
968 --------------------
970 function Length_Of_Name (Id : Name_Id) return Nat is
971 begin
972 return Int (Name_Entries.Table (Id).Name_Len);
973 end Length_Of_Name;
975 ----------
976 -- Lock --
977 ----------
979 procedure Lock is
980 begin
981 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
982 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
983 Name_Chars.Locked := True;
984 Name_Entries.Locked := True;
985 Name_Chars.Release;
986 Name_Entries.Release;
987 end Lock;
989 ------------------------
990 -- Name_Chars_Address --
991 ------------------------
993 function Name_Chars_Address return System.Address is
994 begin
995 return Name_Chars.Table (0)'Address;
996 end Name_Chars_Address;
998 ----------------
999 -- Name_Enter --
1000 ----------------
1002 function Name_Enter return Name_Id is
1003 begin
1004 Name_Entries.Increment_Last;
1005 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
1006 Name_Chars.Last;
1007 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
1008 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
1009 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
1010 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
1012 -- Set corresponding string entry in the Name_Chars table
1014 for J in 1 .. Name_Len loop
1015 Name_Chars.Increment_Last;
1016 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
1017 end loop;
1019 Name_Chars.Increment_Last;
1020 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
1022 return Name_Entries.Last;
1023 end Name_Enter;
1025 --------------------------
1026 -- Name_Entries_Address --
1027 --------------------------
1029 function Name_Entries_Address return System.Address is
1030 begin
1031 return Name_Entries.Table (First_Name_Id)'Address;
1032 end Name_Entries_Address;
1034 ------------------------
1035 -- Name_Entries_Count --
1036 ------------------------
1038 function Name_Entries_Count return Nat is
1039 begin
1040 return Int (Name_Entries.Last - Name_Entries.First + 1);
1041 end Name_Entries_Count;
1043 ---------------
1044 -- Name_Find --
1045 ---------------
1047 function Name_Find return Name_Id is
1048 New_Id : Name_Id;
1049 -- Id of entry in hash search, and value to be returned
1051 S : Int;
1052 -- Pointer into string table
1054 Hash_Index : Hash_Index_Type;
1055 -- Computed hash index
1057 begin
1058 -- Quick handling for one character names
1060 if Name_Len = 1 then
1061 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1063 -- Otherwise search hash table for existing matching entry
1065 else
1066 Hash_Index := Namet.Hash;
1067 New_Id := Hash_Table (Hash_Index);
1069 if New_Id = No_Name then
1070 Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1072 else
1073 Search : loop
1074 if Name_Len /=
1075 Integer (Name_Entries.Table (New_Id).Name_Len)
1076 then
1077 goto No_Match;
1078 end if;
1080 S := Name_Entries.Table (New_Id).Name_Chars_Index;
1082 for J in 1 .. Name_Len loop
1083 if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1084 goto No_Match;
1085 end if;
1086 end loop;
1088 return New_Id;
1090 -- Current entry in hash chain does not match
1092 <<No_Match>>
1093 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1094 New_Id := Name_Entries.Table (New_Id).Hash_Link;
1095 else
1096 Name_Entries.Table (New_Id).Hash_Link :=
1097 Name_Entries.Last + 1;
1098 exit Search;
1099 end if;
1101 end loop Search;
1102 end if;
1104 -- We fall through here only if a matching entry was not found in the
1105 -- hash table. We now create a new entry in the names table. The hash
1106 -- link pointing to the new entry (Name_Entries.Last+1) has been set.
1108 Name_Entries.Increment_Last;
1109 Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
1110 Name_Chars.Last;
1111 Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len);
1112 Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
1113 Name_Entries.Table (Name_Entries.Last).Int_Info := 0;
1114 Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
1116 -- Set corresponding string entry in the Name_Chars table
1118 for J in 1 .. Name_Len loop
1119 Name_Chars.Increment_Last;
1120 Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
1121 end loop;
1123 Name_Chars.Increment_Last;
1124 Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
1126 return Name_Entries.Last;
1127 end if;
1128 end Name_Find;
1130 ----------------------
1131 -- Reset_Name_Table --
1132 ----------------------
1134 procedure Reset_Name_Table is
1135 begin
1136 for J in First_Name_Id .. Name_Entries.Last loop
1137 Name_Entries.Table (J).Int_Info := 0;
1138 Name_Entries.Table (J).Byte_Info := 0;
1139 end loop;
1140 end Reset_Name_Table;
1142 --------------------------------
1143 -- Set_Character_Literal_Name --
1144 --------------------------------
1146 procedure Set_Character_Literal_Name (C : Char_Code) is
1147 begin
1148 Name_Buffer (1) := 'Q';
1149 Name_Len := 1;
1150 Store_Encoded_Character (C);
1151 end Set_Character_Literal_Name;
1153 -------------------------
1154 -- Set_Name_Table_Byte --
1155 -------------------------
1157 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1158 begin
1159 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1160 Name_Entries.Table (Id).Byte_Info := Val;
1161 end Set_Name_Table_Byte;
1163 -------------------------
1164 -- Set_Name_Table_Info --
1165 -------------------------
1167 procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1168 begin
1169 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1170 Name_Entries.Table (Id).Int_Info := Val;
1171 end Set_Name_Table_Info;
1173 -----------------------------
1174 -- Store_Encoded_Character --
1175 -----------------------------
1177 procedure Store_Encoded_Character (C : Char_Code) is
1179 procedure Set_Hex_Chars (C : Char_Code);
1180 -- Stores given value, which is in the range 0 .. 255, as two hex
1181 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1183 -------------------
1184 -- Set_Hex_Chars --
1185 -------------------
1187 procedure Set_Hex_Chars (C : Char_Code) is
1188 Hexd : constant String := "0123456789abcdef";
1189 N : constant Natural := Natural (C);
1190 begin
1191 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1192 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1193 Name_Len := Name_Len + 2;
1194 end Set_Hex_Chars;
1196 -- Start of processing for Store_Encoded_Character
1198 begin
1199 Name_Len := Name_Len + 1;
1201 if In_Character_Range (C) then
1202 declare
1203 CC : constant Character := Get_Character (C);
1204 begin
1205 if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1206 Name_Buffer (Name_Len) := CC;
1207 else
1208 Name_Buffer (Name_Len) := 'U';
1209 Set_Hex_Chars (C);
1210 end if;
1211 end;
1213 elsif In_Wide_Character_Range (C) then
1214 Name_Buffer (Name_Len) := 'W';
1215 Set_Hex_Chars (C / 256);
1216 Set_Hex_Chars (C mod 256);
1218 else
1219 Name_Buffer (Name_Len) := 'W';
1220 Name_Len := Name_Len + 1;
1221 Name_Buffer (Name_Len) := 'W';
1222 Set_Hex_Chars (C / 2 ** 24);
1223 Set_Hex_Chars ((C / 2 ** 16) mod 256);
1224 Set_Hex_Chars ((C / 256) mod 256);
1225 Set_Hex_Chars (C mod 256);
1226 end if;
1227 end Store_Encoded_Character;
1229 --------------------------------------
1230 -- Strip_Qualification_And_Suffixes --
1231 --------------------------------------
1233 procedure Strip_Qualification_And_Suffixes is
1234 J : Integer;
1236 begin
1237 -- Strip package body qualification string off end
1239 for J in reverse 2 .. Name_Len loop
1240 if Name_Buffer (J) = 'X' then
1241 Name_Len := J - 1;
1242 exit;
1243 end if;
1245 exit when Name_Buffer (J) /= 'b'
1246 and then Name_Buffer (J) /= 'n'
1247 and then Name_Buffer (J) /= 'p';
1248 end loop;
1250 -- Find rightmost __ or $ separator if one exists. First we position
1251 -- to start the search. If we have a character constant, position
1252 -- just before it, otherwise position to last character but one
1254 if Name_Buffer (Name_Len) = ''' then
1255 J := Name_Len - 2;
1256 while J > 0 and then Name_Buffer (J) /= ''' loop
1257 J := J - 1;
1258 end loop;
1260 else
1261 J := Name_Len - 1;
1262 end if;
1264 -- Loop to search for rightmost __ or $ (homonym) separator
1266 while J > 1 loop
1268 -- If $ separator, homonym separator, so strip it and keep looking
1270 if Name_Buffer (J) = '$' then
1271 Name_Len := J - 1;
1272 J := Name_Len - 1;
1274 -- Else check for __ found
1276 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1278 -- Found __ so see if digit follows, and if so, this is a
1279 -- homonym separator, so strip it and keep looking.
1281 if Name_Buffer (J + 2) in '0' .. '9' then
1282 Name_Len := J - 1;
1283 J := Name_Len - 1;
1285 -- If not a homonym separator, then we simply strip the
1286 -- separator and everything that precedes it, and we are done
1288 else
1289 Name_Buffer (1 .. Name_Len - J - 1) :=
1290 Name_Buffer (J + 2 .. Name_Len);
1291 Name_Len := Name_Len - J - 1;
1292 exit;
1293 end if;
1295 else
1296 J := J - 1;
1297 end if;
1298 end loop;
1299 end Strip_Qualification_And_Suffixes;
1301 ---------------
1302 -- Tree_Read --
1303 ---------------
1305 procedure Tree_Read is
1306 begin
1307 Name_Chars.Tree_Read;
1308 Name_Entries.Tree_Read;
1310 Tree_Read_Data
1311 (Hash_Table'Address,
1312 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1313 end Tree_Read;
1315 ----------------
1316 -- Tree_Write --
1317 ----------------
1319 procedure Tree_Write is
1320 begin
1321 Name_Chars.Tree_Write;
1322 Name_Entries.Tree_Write;
1324 Tree_Write_Data
1325 (Hash_Table'Address,
1326 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1327 end Tree_Write;
1329 ------------
1330 -- Unlock --
1331 ------------
1333 procedure Unlock is
1334 begin
1335 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1336 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1337 Name_Chars.Locked := False;
1338 Name_Entries.Locked := False;
1339 Name_Chars.Release;
1340 Name_Entries.Release;
1341 end Unlock;
1343 --------
1344 -- wn --
1345 --------
1347 procedure wn (Id : Name_Id) is
1348 begin
1349 Write_Name (Id);
1350 Write_Eol;
1351 end wn;
1353 ----------------
1354 -- Write_Name --
1355 ----------------
1357 procedure Write_Name (Id : Name_Id) is
1358 begin
1359 if Id >= First_Name_Id then
1360 Get_Name_String (Id);
1361 Write_Str (Name_Buffer (1 .. Name_Len));
1362 end if;
1363 end Write_Name;
1365 ------------------------
1366 -- Write_Name_Decoded --
1367 ------------------------
1369 procedure Write_Name_Decoded (Id : Name_Id) is
1370 begin
1371 if Id >= First_Name_Id then
1372 Get_Decoded_Name_String (Id);
1373 Write_Str (Name_Buffer (1 .. Name_Len));
1374 end if;
1375 end Write_Name_Decoded;
1377 end Namet;