OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [namet.adb] - Blame information for rev 283

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                N A M E T                                 --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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 Tree_IO;  use Tree_IO;
40
with Widechar; use Widechar;
41
 
42
package body Namet is
43
 
44
   Name_Chars_Reserve   : constant := 5000;
45
   Name_Entries_Reserve : constant := 100;
46
   --  The names table is locked during gigi processing, since gigi assumes
47
   --  that the table does not move. After returning from gigi, the names
48
   --  table is unlocked again, since writing library file information needs
49
   --  to generate some extra names. To avoid the inefficiency of always
50
   --  reallocating during this second unlocked phase, we reserve a bit of
51
   --  extra space before doing the release call.
52
 
53
   Hash_Num : constant Int := 2**12;
54
   --  Number of headers in the hash table. Current hash algorithm is closely
55
   --  tailored to this choice, so it can only be changed if a corresponding
56
   --  change is made to the hash algorithm.
57
 
58
   Hash_Max : constant Int := Hash_Num - 1;
59
   --  Indexes in the hash header table run from 0 to Hash_Num - 1
60
 
61
   subtype Hash_Index_Type is Int range 0 .. Hash_Max;
62
   --  Range of hash index values
63
 
64
   Hash_Table : array (Hash_Index_Type) of Name_Id;
65
   --  The hash table is used to locate existing entries in the names table.
66
   --  The entries point to the first names table entry whose hash value
67
   --  matches the hash code. Then subsequent names table entries with the
68
   --  same hash code value are linked through the Hash_Link fields.
69
 
70
   -----------------------
71
   -- Local Subprograms --
72
   -----------------------
73
 
74
   function Hash return Hash_Index_Type;
75
   pragma Inline (Hash);
76
   --  Compute hash code for name stored in Name_Buffer (length in Name_Len)
77
 
78
   procedure Strip_Qualification_And_Suffixes;
79
   --  Given an encoded entity name in Name_Buffer, remove package body
80
   --  suffix as described for Strip_Package_Body_Suffix, and also remove
81
   --  all qualification, i.e. names followed by two underscores. The
82
   --  contents of Name_Buffer is modified by this call, and on return
83
   --  Name_Buffer and Name_Len reflect the stripped name.
84
 
85
   -----------------------------
86
   -- Add_Char_To_Name_Buffer --
87
   -----------------------------
88
 
89
   procedure Add_Char_To_Name_Buffer (C : Character) is
90
   begin
91
      if Name_Len < Name_Buffer'Last then
92
         Name_Len := Name_Len + 1;
93
         Name_Buffer (Name_Len) := C;
94
      end if;
95
   end Add_Char_To_Name_Buffer;
96
 
97
   ----------------------------
98
   -- Add_Nat_To_Name_Buffer --
99
   ----------------------------
100
 
101
   procedure Add_Nat_To_Name_Buffer (V : Nat) is
102
   begin
103
      if V >= 10 then
104
         Add_Nat_To_Name_Buffer (V / 10);
105
      end if;
106
 
107
      Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
108
   end Add_Nat_To_Name_Buffer;
109
 
110
   ----------------------------
111
   -- Add_Str_To_Name_Buffer --
112
   ----------------------------
113
 
114
   procedure Add_Str_To_Name_Buffer (S : String) is
115
   begin
116
      for J in S'Range loop
117
         Add_Char_To_Name_Buffer (S (J));
118
      end loop;
119
   end Add_Str_To_Name_Buffer;
120
 
121
   --------------
122
   -- Finalize --
123
   --------------
124
 
125
   procedure Finalize is
126
      Max_Chain_Length : constant := 50;
127
      --  Max length of chains for which specific information is output
128
 
129
      F : array (Int range 0 .. Max_Chain_Length) of Int;
130
      --  N'th entry is number of chains of length N
131
 
132
      Probes : Int := 0;
133
      --  Used to compute average number of probes
134
 
135
      Nsyms : Int := 0;
136
      --  Number of symbols in table
137
 
138
   begin
139
      if Debug_Flag_H then
140
         for J in F'Range loop
141
            F (J) := 0;
142
         end loop;
143
 
144
         for J in Hash_Index_Type loop
145
            if Hash_Table (J) = No_Name then
146
               F (0) := F (0) + 1;
147
 
148
            else
149
               Write_Str ("Hash_Table (");
150
               Write_Int (J);
151
               Write_Str (") has ");
152
 
153
               declare
154
                  C : Int := 1;
155
                  N : Name_Id;
156
                  S : Int;
157
 
158
               begin
159
                  C := 0;
160
                  N := Hash_Table (J);
161
 
162
                  while N /= No_Name loop
163
                     N := Name_Entries.Table (N).Hash_Link;
164
                     C := C + 1;
165
                  end loop;
166
 
167
                  Write_Int (C);
168
                  Write_Str (" entries");
169
                  Write_Eol;
170
 
171
                  if C < Max_Chain_Length then
172
                     F (C) := F (C) + 1;
173
                  else
174
                     F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
175
                  end if;
176
 
177
                  N := Hash_Table (J);
178
 
179
                  while N /= No_Name loop
180
                     S := Name_Entries.Table (N).Name_Chars_Index;
181
                     Write_Str ("      ");
182
 
183
                     for J in 1 .. Name_Entries.Table (N).Name_Len loop
184
                        Write_Char (Name_Chars.Table (S + Int (J)));
185
                     end loop;
186
 
187
                     Write_Eol;
188
                     N := Name_Entries.Table (N).Hash_Link;
189
                  end loop;
190
               end;
191
            end if;
192
         end loop;
193
 
194
         Write_Eol;
195
 
196
         for J in Int range 0 .. Max_Chain_Length loop
197
            if F (J) /= 0 then
198
               Write_Str ("Number of hash chains of length ");
199
 
200
               if J < 10 then
201
                  Write_Char (' ');
202
               end if;
203
 
204
               Write_Int (J);
205
 
206
               if J = Max_Chain_Length then
207
                  Write_Str (" or greater");
208
               end if;
209
 
210
               Write_Str (" = ");
211
               Write_Int (F (J));
212
               Write_Eol;
213
 
214
               if J /= 0 then
215
                  Nsyms := Nsyms + F (J);
216
                  Probes := Probes + F (J) * (1 + J) * 100;
217
               end if;
218
            end if;
219
         end loop;
220
 
221
         Write_Eol;
222
         Write_Str ("Average number of probes for lookup = ");
223
         Probes := Probes / Nsyms;
224
         Write_Int (Probes / 200);
225
         Write_Char ('.');
226
         Probes := (Probes mod 200) / 2;
227
         Write_Char (Character'Val (48 + Probes / 10));
228
         Write_Char (Character'Val (48 + Probes mod 10));
229
         Write_Eol;
230
         Write_Eol;
231
      end if;
232
   end Finalize;
233
 
234
   -----------------------------
235
   -- Get_Decoded_Name_String --
236
   -----------------------------
237
 
238
   procedure Get_Decoded_Name_String (Id : Name_Id) is
239
      C : Character;
240
      P : Natural;
241
 
242
   begin
243
      Get_Name_String (Id);
244
 
245
      --  Skip scan if we already know there are no encodings
246
 
247
      if Name_Entries.Table (Id).Name_Has_No_Encodings then
248
         return;
249
      end if;
250
 
251
      --  Quick loop to see if there is anything special to do
252
 
253
      P := 1;
254
      loop
255
         if P = Name_Len then
256
            Name_Entries.Table (Id).Name_Has_No_Encodings := True;
257
            return;
258
 
259
         else
260
            C := Name_Buffer (P);
261
 
262
            exit when
263
              C = 'U' or else
264
              C = 'W' or else
265
              C = 'Q' or else
266
              C = 'O';
267
 
268
            P := P + 1;
269
         end if;
270
      end loop;
271
 
272
      --  Here we have at least some encoding that we must decode
273
 
274
      Decode : declare
275
         New_Len : Natural;
276
         Old     : Positive;
277
         New_Buf : String (1 .. Name_Buffer'Last);
278
 
279
         procedure Copy_One_Character;
280
         --  Copy a character from Name_Buffer to New_Buf. Includes case
281
         --  of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
282
 
283
         function Hex (N : Natural) return Word;
284
         --  Scans past N digits using Old pointer and returns hex value
285
 
286
         procedure Insert_Character (C : Character);
287
         --  Insert a new character into output decoded name
288
 
289
         ------------------------
290
         -- Copy_One_Character --
291
         ------------------------
292
 
293
         procedure Copy_One_Character is
294
            C : Character;
295
 
296
         begin
297
            C := Name_Buffer (Old);
298
 
299
            --  U (upper half insertion case)
300
 
301
            if C = 'U'
302
              and then Old < Name_Len
303
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
304
              and then Name_Buffer (Old + 1) /= '_'
305
            then
306
               Old := Old + 1;
307
 
308
               --  If we have upper half encoding, then we have to set an
309
               --  appropriate wide character sequence for this character.
310
 
311
               if Upper_Half_Encoding then
312
                  Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
313
 
314
                  --  For other encoding methods, upper half characters can
315
                  --  simply use their normal representation.
316
 
317
               else
318
                  Insert_Character (Character'Val (Hex (2)));
319
               end if;
320
 
321
            --  WW (wide wide character insertion)
322
 
323
            elsif C = 'W'
324
              and then Old < Name_Len
325
              and then Name_Buffer (Old + 1) = 'W'
326
            then
327
               Old := Old + 2;
328
               Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
329
 
330
            --  W (wide character insertion)
331
 
332
            elsif C = 'W'
333
              and then Old < Name_Len
334
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
335
              and then Name_Buffer (Old + 1) /= '_'
336
            then
337
               Old := Old + 1;
338
               Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
339
 
340
            --  Any other character is copied unchanged
341
 
342
            else
343
               Insert_Character (C);
344
               Old := Old + 1;
345
            end if;
346
         end Copy_One_Character;
347
 
348
         ---------
349
         -- Hex --
350
         ---------
351
 
352
         function Hex (N : Natural) return Word is
353
            T : Word := 0;
354
            C : Character;
355
 
356
         begin
357
            for J in 1 .. N loop
358
               C := Name_Buffer (Old);
359
               Old := Old + 1;
360
 
361
               pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
362
 
363
               if C <= '9' then
364
                  T := 16 * T + Character'Pos (C) - Character'Pos ('0');
365
               else -- C in 'a' .. 'f'
366
                  T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
367
               end if;
368
            end loop;
369
 
370
            return T;
371
         end Hex;
372
 
373
         ----------------------
374
         -- Insert_Character --
375
         ----------------------
376
 
377
         procedure Insert_Character (C : Character) is
378
         begin
379
            New_Len := New_Len + 1;
380
            New_Buf (New_Len) := C;
381
         end Insert_Character;
382
 
383
      --  Start of processing for Decode
384
 
385
      begin
386
         New_Len := 0;
387
         Old := 1;
388
 
389
         --  Loop through characters of name
390
 
391
         while Old <= Name_Len loop
392
 
393
            --  Case of character literal, put apostrophes around character
394
 
395
            if Name_Buffer (Old) = 'Q'
396
              and then Old < Name_Len
397
            then
398
               Old := Old + 1;
399
               Insert_Character (''');
400
               Copy_One_Character;
401
               Insert_Character (''');
402
 
403
            --  Case of operator name
404
 
405
            elsif Name_Buffer (Old) = 'O'
406
              and then Old < Name_Len
407
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
408
              and then Name_Buffer (Old + 1) /= '_'
409
            then
410
               Old := Old + 1;
411
 
412
               declare
413
                  --  This table maps the 2nd and 3rd characters of the name
414
                  --  into the required output. Two blanks means leave the
415
                  --  name alone
416
 
417
                  Map : constant String :=
418
                     "ab  " &               --  Oabs         => "abs"
419
                     "ad+ " &               --  Oadd         => "+"
420
                     "an  " &               --  Oand         => "and"
421
                     "co& " &               --  Oconcat      => "&"
422
                     "di/ " &               --  Odivide      => "/"
423
                     "eq= " &               --  Oeq          => "="
424
                     "ex**" &               --  Oexpon       => "**"
425
                     "gt> " &               --  Ogt          => ">"
426
                     "ge>=" &               --  Oge          => ">="
427
                     "le<=" &               --  Ole          => "<="
428
                     "lt< " &               --  Olt          => "<"
429
                     "mo  " &               --  Omod         => "mod"
430
                     "mu* " &               --  Omutliply    => "*"
431
                     "ne/=" &               --  One          => "/="
432
                     "no  " &               --  Onot         => "not"
433
                     "or  " &               --  Oor          => "or"
434
                     "re  " &               --  Orem         => "rem"
435
                     "su- " &               --  Osubtract    => "-"
436
                     "xo  ";                --  Oxor         => "xor"
437
 
438
                  J : Integer;
439
 
440
               begin
441
                  Insert_Character ('"');
442
 
443
                  --  Search the map. Note that this loop must terminate, if
444
                  --  not we have some kind of internal error, and a constraint
445
                  --  error may be raised.
446
 
447
                  J := Map'First;
448
                  loop
449
                     exit when Name_Buffer (Old) = Map (J)
450
                       and then Name_Buffer (Old + 1) = Map (J + 1);
451
                     J := J + 4;
452
                  end loop;
453
 
454
                  --  Special operator name
455
 
456
                  if Map (J + 2) /= ' ' then
457
                     Insert_Character (Map (J + 2));
458
 
459
                     if Map (J + 3) /= ' ' then
460
                        Insert_Character (Map (J + 3));
461
                     end if;
462
 
463
                     Insert_Character ('"');
464
 
465
                     --  Skip past original operator name in input
466
 
467
                     while Old <= Name_Len
468
                       and then Name_Buffer (Old) in 'a' .. 'z'
469
                     loop
470
                        Old := Old + 1;
471
                     end loop;
472
 
473
                  --  For other operator names, leave them in lower case,
474
                  --  surrounded by apostrophes
475
 
476
                  else
477
                     --  Copy original operator name from input to output
478
 
479
                     while Old <= Name_Len
480
                        and then Name_Buffer (Old) in 'a' .. 'z'
481
                     loop
482
                        Copy_One_Character;
483
                     end loop;
484
 
485
                     Insert_Character ('"');
486
                  end if;
487
               end;
488
 
489
            --  Else copy one character and keep going
490
 
491
            else
492
               Copy_One_Character;
493
            end if;
494
         end loop;
495
 
496
         --  Copy new buffer as result
497
 
498
         Name_Len := New_Len;
499
         Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
500
      end Decode;
501
   end Get_Decoded_Name_String;
502
 
503
   -------------------------------------------
504
   -- Get_Decoded_Name_String_With_Brackets --
505
   -------------------------------------------
506
 
507
   procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
508
      P : Natural;
509
 
510
   begin
511
      --  Case of operator name, normal decoding is fine
512
 
513
      if Name_Buffer (1) = 'O' then
514
         Get_Decoded_Name_String (Id);
515
 
516
      --  For character literals, normal decoding is fine
517
 
518
      elsif Name_Buffer (1) = 'Q' then
519
         Get_Decoded_Name_String (Id);
520
 
521
      --  Only remaining issue is U/W/WW sequences
522
 
523
      else
524
         Get_Name_String (Id);
525
 
526
         P := 1;
527
         while P < Name_Len loop
528
            if Name_Buffer (P + 1) in 'A' .. 'Z' then
529
               P := P + 1;
530
 
531
            --  Uhh encoding
532
 
533
            elsif Name_Buffer (P) = 'U' then
534
               for J in reverse P + 3 .. P + Name_Len loop
535
                  Name_Buffer (J + 3) := Name_Buffer (J);
536
               end loop;
537
 
538
               Name_Len := Name_Len + 3;
539
               Name_Buffer (P + 3) := Name_Buffer (P + 2);
540
               Name_Buffer (P + 2) := Name_Buffer (P + 1);
541
               Name_Buffer (P)     := '[';
542
               Name_Buffer (P + 1) := '"';
543
               Name_Buffer (P + 4) := '"';
544
               Name_Buffer (P + 5) := ']';
545
               P := P + 6;
546
 
547
            --  WWhhhhhhhh encoding
548
 
549
            elsif Name_Buffer (P) = 'W'
550
              and then P + 9 <= Name_Len
551
              and then Name_Buffer (P + 1) = 'W'
552
              and then Name_Buffer (P + 2) not in 'A' .. 'Z'
553
              and then Name_Buffer (P + 2) /= '_'
554
            then
555
               Name_Buffer (P + 12 .. Name_Len + 2) :=
556
                 Name_Buffer (P + 10 .. Name_Len);
557
               Name_Buffer (P)     := '[';
558
               Name_Buffer (P + 1) := '"';
559
               Name_Buffer (P + 10) := '"';
560
               Name_Buffer (P + 11) := ']';
561
               Name_Len := Name_Len + 2;
562
               P := P + 12;
563
 
564
            --  Whhhh encoding
565
 
566
            elsif Name_Buffer (P) = 'W'
567
              and then P < Name_Len
568
              and then Name_Buffer (P + 1) not in 'A' .. 'Z'
569
              and then Name_Buffer (P + 1) /= '_'
570
            then
571
               Name_Buffer (P + 8 .. P + Name_Len + 3) :=
572
                 Name_Buffer (P + 5 .. Name_Len);
573
               Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
574
               Name_Buffer (P)     := '[';
575
               Name_Buffer (P + 1) := '"';
576
               Name_Buffer (P + 6) := '"';
577
               Name_Buffer (P + 7) := ']';
578
               Name_Len := Name_Len + 3;
579
               P := P + 8;
580
 
581
            else
582
               P := P + 1;
583
            end if;
584
         end loop;
585
      end if;
586
   end Get_Decoded_Name_String_With_Brackets;
587
 
588
   ------------------------
589
   -- Get_Last_Two_Chars --
590
   ------------------------
591
 
592
   procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
593
      NE  : Name_Entry renames Name_Entries.Table (N);
594
      NEL : constant Int := Int (NE.Name_Len);
595
 
596
   begin
597
      if NEL >= 2 then
598
         C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
599
         C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
600
      else
601
         C1 := ASCII.NUL;
602
         C2 := ASCII.NUL;
603
      end if;
604
   end Get_Last_Two_Chars;
605
 
606
   ---------------------
607
   -- Get_Name_String --
608
   ---------------------
609
 
610
   --  Procedure version leaving result in Name_Buffer, length in Name_Len
611
 
612
   procedure Get_Name_String (Id : Name_Id) is
613
      S : Int;
614
 
615
   begin
616
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
617
 
618
      S := Name_Entries.Table (Id).Name_Chars_Index;
619
      Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
620
 
621
      for J in 1 .. Name_Len loop
622
         Name_Buffer (J) := Name_Chars.Table (S + Int (J));
623
      end loop;
624
   end Get_Name_String;
625
 
626
   ---------------------
627
   -- Get_Name_String --
628
   ---------------------
629
 
630
   --  Function version returning a string
631
 
632
   function Get_Name_String (Id : Name_Id) return String is
633
      S : Int;
634
 
635
   begin
636
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
637
      S := Name_Entries.Table (Id).Name_Chars_Index;
638
 
639
      declare
640
         R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
641
 
642
      begin
643
         for J in R'Range loop
644
            R (J) := Name_Chars.Table (S + Int (J));
645
         end loop;
646
 
647
         return R;
648
      end;
649
   end Get_Name_String;
650
 
651
   --------------------------------
652
   -- Get_Name_String_And_Append --
653
   --------------------------------
654
 
655
   procedure Get_Name_String_And_Append (Id : Name_Id) is
656
      S : Int;
657
 
658
   begin
659
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
660
 
661
      S := Name_Entries.Table (Id).Name_Chars_Index;
662
 
663
      for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
664
         Name_Len := Name_Len + 1;
665
         Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
666
      end loop;
667
   end Get_Name_String_And_Append;
668
 
669
   -------------------------
670
   -- Get_Name_Table_Byte --
671
   -------------------------
672
 
673
   function Get_Name_Table_Byte (Id : Name_Id) return Byte is
674
   begin
675
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
676
      return Name_Entries.Table (Id).Byte_Info;
677
   end Get_Name_Table_Byte;
678
 
679
   -------------------------
680
   -- Get_Name_Table_Info --
681
   -------------------------
682
 
683
   function Get_Name_Table_Info (Id : Name_Id) return Int is
684
   begin
685
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
686
      return Name_Entries.Table (Id).Int_Info;
687
   end Get_Name_Table_Info;
688
 
689
   -----------------------------------------
690
   -- Get_Unqualified_Decoded_Name_String --
691
   -----------------------------------------
692
 
693
   procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
694
   begin
695
      Get_Decoded_Name_String (Id);
696
      Strip_Qualification_And_Suffixes;
697
   end Get_Unqualified_Decoded_Name_String;
698
 
699
   ---------------------------------
700
   -- Get_Unqualified_Name_String --
701
   ---------------------------------
702
 
703
   procedure Get_Unqualified_Name_String (Id : Name_Id) is
704
   begin
705
      Get_Name_String (Id);
706
      Strip_Qualification_And_Suffixes;
707
   end Get_Unqualified_Name_String;
708
 
709
   ----------
710
   -- Hash --
711
   ----------
712
 
713
   function Hash return Hash_Index_Type is
714
   begin
715
      --  For the cases of 1-12 characters, all characters participate in the
716
      --  hash. The positioning is randomized, with the bias that characters
717
      --  later on participate fully (i.e. are added towards the right side).
718
 
719
      case Name_Len is
720
 
721
         when 0 =>
722
            return 0;
723
 
724
         when 1 =>
725
            return
726
               Character'Pos (Name_Buffer (1));
727
 
728
         when 2 =>
729
            return ((
730
              Character'Pos (Name_Buffer (1))) * 64 +
731
              Character'Pos (Name_Buffer (2))) mod Hash_Num;
732
 
733
         when 3 =>
734
            return (((
735
              Character'Pos (Name_Buffer (1))) * 16 +
736
              Character'Pos (Name_Buffer (3))) * 16 +
737
              Character'Pos (Name_Buffer (2))) mod Hash_Num;
738
 
739
         when 4 =>
740
            return ((((
741
              Character'Pos (Name_Buffer (1))) * 8 +
742
              Character'Pos (Name_Buffer (2))) * 8 +
743
              Character'Pos (Name_Buffer (3))) * 8 +
744
              Character'Pos (Name_Buffer (4))) mod Hash_Num;
745
 
746
         when 5 =>
747
            return (((((
748
              Character'Pos (Name_Buffer (4))) * 8 +
749
              Character'Pos (Name_Buffer (1))) * 4 +
750
              Character'Pos (Name_Buffer (3))) * 4 +
751
              Character'Pos (Name_Buffer (5))) * 8 +
752
              Character'Pos (Name_Buffer (2))) mod Hash_Num;
753
 
754
         when 6 =>
755
            return ((((((
756
              Character'Pos (Name_Buffer (5))) * 4 +
757
              Character'Pos (Name_Buffer (1))) * 4 +
758
              Character'Pos (Name_Buffer (4))) * 4 +
759
              Character'Pos (Name_Buffer (2))) * 4 +
760
              Character'Pos (Name_Buffer (6))) * 4 +
761
              Character'Pos (Name_Buffer (3))) mod Hash_Num;
762
 
763
         when 7 =>
764
            return (((((((
765
              Character'Pos (Name_Buffer (4))) * 4 +
766
              Character'Pos (Name_Buffer (3))) * 4 +
767
              Character'Pos (Name_Buffer (1))) * 4 +
768
              Character'Pos (Name_Buffer (2))) * 2 +
769
              Character'Pos (Name_Buffer (5))) * 2 +
770
              Character'Pos (Name_Buffer (7))) * 2 +
771
              Character'Pos (Name_Buffer (6))) mod Hash_Num;
772
 
773
         when 8 =>
774
            return ((((((((
775
              Character'Pos (Name_Buffer (2))) * 4 +
776
              Character'Pos (Name_Buffer (1))) * 4 +
777
              Character'Pos (Name_Buffer (3))) * 2 +
778
              Character'Pos (Name_Buffer (5))) * 2 +
779
              Character'Pos (Name_Buffer (7))) * 2 +
780
              Character'Pos (Name_Buffer (6))) * 2 +
781
              Character'Pos (Name_Buffer (4))) * 2 +
782
              Character'Pos (Name_Buffer (8))) mod Hash_Num;
783
 
784
         when 9 =>
785
            return (((((((((
786
              Character'Pos (Name_Buffer (2))) * 4 +
787
              Character'Pos (Name_Buffer (1))) * 4 +
788
              Character'Pos (Name_Buffer (3))) * 4 +
789
              Character'Pos (Name_Buffer (4))) * 2 +
790
              Character'Pos (Name_Buffer (8))) * 2 +
791
              Character'Pos (Name_Buffer (7))) * 2 +
792
              Character'Pos (Name_Buffer (5))) * 2 +
793
              Character'Pos (Name_Buffer (6))) * 2 +
794
              Character'Pos (Name_Buffer (9))) mod Hash_Num;
795
 
796
         when 10 =>
797
            return ((((((((((
798
              Character'Pos (Name_Buffer (01))) * 2 +
799
              Character'Pos (Name_Buffer (02))) * 2 +
800
              Character'Pos (Name_Buffer (08))) * 2 +
801
              Character'Pos (Name_Buffer (03))) * 2 +
802
              Character'Pos (Name_Buffer (04))) * 2 +
803
              Character'Pos (Name_Buffer (09))) * 2 +
804
              Character'Pos (Name_Buffer (06))) * 2 +
805
              Character'Pos (Name_Buffer (05))) * 2 +
806
              Character'Pos (Name_Buffer (07))) * 2 +
807
              Character'Pos (Name_Buffer (10))) mod Hash_Num;
808
 
809
         when 11 =>
810
            return (((((((((((
811
              Character'Pos (Name_Buffer (05))) * 2 +
812
              Character'Pos (Name_Buffer (01))) * 2 +
813
              Character'Pos (Name_Buffer (06))) * 2 +
814
              Character'Pos (Name_Buffer (09))) * 2 +
815
              Character'Pos (Name_Buffer (07))) * 2 +
816
              Character'Pos (Name_Buffer (03))) * 2 +
817
              Character'Pos (Name_Buffer (08))) * 2 +
818
              Character'Pos (Name_Buffer (02))) * 2 +
819
              Character'Pos (Name_Buffer (10))) * 2 +
820
              Character'Pos (Name_Buffer (04))) * 2 +
821
              Character'Pos (Name_Buffer (11))) mod Hash_Num;
822
 
823
         when 12 =>
824
            return ((((((((((((
825
              Character'Pos (Name_Buffer (03))) * 2 +
826
              Character'Pos (Name_Buffer (02))) * 2 +
827
              Character'Pos (Name_Buffer (05))) * 2 +
828
              Character'Pos (Name_Buffer (01))) * 2 +
829
              Character'Pos (Name_Buffer (06))) * 2 +
830
              Character'Pos (Name_Buffer (04))) * 2 +
831
              Character'Pos (Name_Buffer (08))) * 2 +
832
              Character'Pos (Name_Buffer (11))) * 2 +
833
              Character'Pos (Name_Buffer (07))) * 2 +
834
              Character'Pos (Name_Buffer (09))) * 2 +
835
              Character'Pos (Name_Buffer (10))) * 2 +
836
              Character'Pos (Name_Buffer (12))) mod Hash_Num;
837
 
838
         --  Names longer than 12 characters are handled by taking the first
839
         --  6 odd numbered characters and the last 6 even numbered characters.
840
 
841
         when others => declare
842
               Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
843
         begin
844
            return ((((((((((((
845
              Character'Pos (Name_Buffer (01))) * 2 +
846
              Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
847
              Character'Pos (Name_Buffer (03))) * 2 +
848
              Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
849
              Character'Pos (Name_Buffer (05))) * 2 +
850
              Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
851
              Character'Pos (Name_Buffer (07))) * 2 +
852
              Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
853
              Character'Pos (Name_Buffer (09))) * 2 +
854
              Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
855
              Character'Pos (Name_Buffer (11))) * 2 +
856
              Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
857
         end;
858
      end case;
859
   end Hash;
860
 
861
   ----------------
862
   -- Initialize --
863
   ----------------
864
 
865
   procedure Initialize is
866
   begin
867
      Name_Chars.Init;
868
      Name_Entries.Init;
869
 
870
      --  Initialize entries for one character names
871
 
872
      for C in Character loop
873
         Name_Entries.Append
874
           ((Name_Chars_Index      => Name_Chars.Last,
875
             Name_Len              => 1,
876
             Byte_Info             => 0,
877
             Int_Info              => 0,
878
             Name_Has_No_Encodings => True,
879
             Hash_Link             => No_Name));
880
 
881
         Name_Chars.Append (C);
882
         Name_Chars.Append (ASCII.NUL);
883
      end loop;
884
 
885
      --  Clear hash table
886
 
887
      for J in Hash_Index_Type loop
888
         Hash_Table (J) := No_Name;
889
      end loop;
890
   end Initialize;
891
 
892
   ----------------------
893
   -- Is_Internal_Name --
894
   ----------------------
895
 
896
   --  Version taking an argument
897
 
898
   function Is_Internal_Name (Id : Name_Id) return Boolean is
899
   begin
900
      Get_Name_String (Id);
901
      return Is_Internal_Name;
902
   end Is_Internal_Name;
903
 
904
   ----------------------
905
   -- Is_Internal_Name --
906
   ----------------------
907
 
908
   --  Version taking its input from Name_Buffer
909
 
910
   function Is_Internal_Name return Boolean is
911
   begin
912
      if Name_Buffer (1) = '_'
913
        or else Name_Buffer (Name_Len) = '_'
914
      then
915
         return True;
916
 
917
      else
918
         --  Test backwards, because we only want to test the last entity
919
         --  name if the name we have is qualified with other entities.
920
 
921
         for J in reverse 1 .. Name_Len loop
922
            if Is_OK_Internal_Letter (Name_Buffer (J)) then
923
               return True;
924
 
925
            --  Quit if we come to terminating double underscore (note that
926
            --  if the current character is an underscore, we know that
927
            --  there is a previous character present, since we already
928
            --  filtered out the case of Name_Buffer (1) = '_' above.
929
 
930
            elsif Name_Buffer (J) = '_'
931
              and then Name_Buffer (J - 1) = '_'
932
              and then Name_Buffer (J - 2) /= '_'
933
            then
934
               return False;
935
            end if;
936
         end loop;
937
      end if;
938
 
939
      return False;
940
   end Is_Internal_Name;
941
 
942
   ---------------------------
943
   -- Is_OK_Internal_Letter --
944
   ---------------------------
945
 
946
   function Is_OK_Internal_Letter (C : Character) return Boolean is
947
   begin
948
      return C in 'A' .. 'Z'
949
        and then C /= 'O'
950
        and then C /= 'Q'
951
        and then C /= 'U'
952
        and then C /= 'W'
953
        and then C /= 'X';
954
   end Is_OK_Internal_Letter;
955
 
956
   ----------------------
957
   -- Is_Operator_Name --
958
   ----------------------
959
 
960
   function Is_Operator_Name (Id : Name_Id) return Boolean is
961
      S : Int;
962
   begin
963
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
964
      S := Name_Entries.Table (Id).Name_Chars_Index;
965
      return Name_Chars.Table (S + 1) = 'O';
966
   end Is_Operator_Name;
967
 
968
   -------------------
969
   -- Is_Valid_Name --
970
   -------------------
971
 
972
   function Is_Valid_Name (Id : Name_Id) return Boolean is
973
   begin
974
      return Id in Name_Entries.First .. Name_Entries.Last;
975
   end Is_Valid_Name;
976
 
977
   --------------------
978
   -- Length_Of_Name --
979
   --------------------
980
 
981
   function Length_Of_Name (Id : Name_Id) return Nat is
982
   begin
983
      return Int (Name_Entries.Table (Id).Name_Len);
984
   end Length_Of_Name;
985
 
986
   ----------
987
   -- Lock --
988
   ----------
989
 
990
   procedure Lock is
991
   begin
992
      Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
993
      Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
994
      Name_Chars.Locked := True;
995
      Name_Entries.Locked := True;
996
      Name_Chars.Release;
997
      Name_Entries.Release;
998
   end Lock;
999
 
1000
   ------------------------
1001
   -- Name_Chars_Address --
1002
   ------------------------
1003
 
1004
   function Name_Chars_Address return System.Address is
1005
   begin
1006
      return Name_Chars.Table (0)'Address;
1007
   end Name_Chars_Address;
1008
 
1009
   ----------------
1010
   -- Name_Enter --
1011
   ----------------
1012
 
1013
   function Name_Enter return Name_Id is
1014
   begin
1015
      Name_Entries.Append
1016
        ((Name_Chars_Index      => Name_Chars.Last,
1017
          Name_Len              => Short (Name_Len),
1018
          Byte_Info             => 0,
1019
          Int_Info              => 0,
1020
          Name_Has_No_Encodings => False,
1021
          Hash_Link             => No_Name));
1022
 
1023
      --  Set corresponding string entry in the Name_Chars table
1024
 
1025
      for J in 1 .. Name_Len loop
1026
         Name_Chars.Append (Name_Buffer (J));
1027
      end loop;
1028
 
1029
      Name_Chars.Append (ASCII.NUL);
1030
 
1031
      return Name_Entries.Last;
1032
   end Name_Enter;
1033
 
1034
   --------------------------
1035
   -- Name_Entries_Address --
1036
   --------------------------
1037
 
1038
   function Name_Entries_Address return System.Address is
1039
   begin
1040
      return Name_Entries.Table (First_Name_Id)'Address;
1041
   end Name_Entries_Address;
1042
 
1043
   ------------------------
1044
   -- Name_Entries_Count --
1045
   ------------------------
1046
 
1047
   function Name_Entries_Count return Nat is
1048
   begin
1049
      return Int (Name_Entries.Last - Name_Entries.First + 1);
1050
   end Name_Entries_Count;
1051
 
1052
   ---------------
1053
   -- Name_Find --
1054
   ---------------
1055
 
1056
   function Name_Find return Name_Id is
1057
      New_Id : Name_Id;
1058
      --  Id of entry in hash search, and value to be returned
1059
 
1060
      S : Int;
1061
      --  Pointer into string table
1062
 
1063
      Hash_Index : Hash_Index_Type;
1064
      --  Computed hash index
1065
 
1066
   begin
1067
      --  Quick handling for one character names
1068
 
1069
      if Name_Len = 1 then
1070
         return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1071
 
1072
      --  Otherwise search hash table for existing matching entry
1073
 
1074
      else
1075
         Hash_Index := Namet.Hash;
1076
         New_Id := Hash_Table (Hash_Index);
1077
 
1078
         if New_Id = No_Name then
1079
            Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1080
 
1081
         else
1082
            Search : loop
1083
               if Name_Len /=
1084
                 Integer (Name_Entries.Table (New_Id).Name_Len)
1085
               then
1086
                  goto No_Match;
1087
               end if;
1088
 
1089
               S := Name_Entries.Table (New_Id).Name_Chars_Index;
1090
 
1091
               for J in 1 .. Name_Len loop
1092
                  if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1093
                     goto No_Match;
1094
                  end if;
1095
               end loop;
1096
 
1097
               return New_Id;
1098
 
1099
               --  Current entry in hash chain does not match
1100
 
1101
               <<No_Match>>
1102
                  if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1103
                     New_Id := Name_Entries.Table (New_Id).Hash_Link;
1104
                  else
1105
                     Name_Entries.Table (New_Id).Hash_Link :=
1106
                       Name_Entries.Last + 1;
1107
                     exit Search;
1108
                  end if;
1109
            end loop Search;
1110
         end if;
1111
 
1112
         --  We fall through here only if a matching entry was not found in the
1113
         --  hash table. We now create a new entry in the names table. The hash
1114
         --  link pointing to the new entry (Name_Entries.Last+1) has been set.
1115
 
1116
         Name_Entries.Append
1117
           ((Name_Chars_Index      => Name_Chars.Last,
1118
             Name_Len              => Short (Name_Len),
1119
             Hash_Link             => No_Name,
1120
             Name_Has_No_Encodings => False,
1121
             Int_Info              => 0,
1122
             Byte_Info             => 0));
1123
 
1124
         --  Set corresponding string entry in the Name_Chars table
1125
 
1126
         for J in 1 .. Name_Len loop
1127
            Name_Chars.Append (Name_Buffer (J));
1128
         end loop;
1129
 
1130
         Name_Chars.Append (ASCII.NUL);
1131
 
1132
         return Name_Entries.Last;
1133
      end if;
1134
   end Name_Find;
1135
 
1136
   ----------------------
1137
   -- Reset_Name_Table --
1138
   ----------------------
1139
 
1140
   procedure Reset_Name_Table is
1141
   begin
1142
      for J in First_Name_Id .. Name_Entries.Last loop
1143
         Name_Entries.Table (J).Int_Info  := 0;
1144
         Name_Entries.Table (J).Byte_Info := 0;
1145
      end loop;
1146
   end Reset_Name_Table;
1147
 
1148
   --------------------------------
1149
   -- Set_Character_Literal_Name --
1150
   --------------------------------
1151
 
1152
   procedure Set_Character_Literal_Name (C : Char_Code) is
1153
   begin
1154
      Name_Buffer (1) := 'Q';
1155
      Name_Len := 1;
1156
      Store_Encoded_Character (C);
1157
   end Set_Character_Literal_Name;
1158
 
1159
   -------------------------
1160
   -- Set_Name_Table_Byte --
1161
   -------------------------
1162
 
1163
   procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1164
   begin
1165
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1166
      Name_Entries.Table (Id).Byte_Info := Val;
1167
   end Set_Name_Table_Byte;
1168
 
1169
   -------------------------
1170
   -- Set_Name_Table_Info --
1171
   -------------------------
1172
 
1173
   procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1174
   begin
1175
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1176
      Name_Entries.Table (Id).Int_Info := Val;
1177
   end Set_Name_Table_Info;
1178
 
1179
   -----------------------------
1180
   -- Store_Encoded_Character --
1181
   -----------------------------
1182
 
1183
   procedure Store_Encoded_Character (C : Char_Code) is
1184
 
1185
      procedure Set_Hex_Chars (C : Char_Code);
1186
      --  Stores given value, which is in the range 0 .. 255, as two hex
1187
      --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1188
 
1189
      -------------------
1190
      -- Set_Hex_Chars --
1191
      -------------------
1192
 
1193
      procedure Set_Hex_Chars (C : Char_Code) is
1194
         Hexd : constant String := "0123456789abcdef";
1195
         N    : constant Natural := Natural (C);
1196
      begin
1197
         Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1198
         Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1199
         Name_Len := Name_Len + 2;
1200
      end Set_Hex_Chars;
1201
 
1202
   --  Start of processing for Store_Encoded_Character
1203
 
1204
   begin
1205
      Name_Len := Name_Len + 1;
1206
 
1207
      if In_Character_Range (C) then
1208
         declare
1209
            CC : constant Character := Get_Character (C);
1210
         begin
1211
            if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1212
               Name_Buffer (Name_Len) := CC;
1213
            else
1214
               Name_Buffer (Name_Len) := 'U';
1215
               Set_Hex_Chars (C);
1216
            end if;
1217
         end;
1218
 
1219
      elsif In_Wide_Character_Range (C) then
1220
         Name_Buffer (Name_Len) := 'W';
1221
         Set_Hex_Chars (C / 256);
1222
         Set_Hex_Chars (C mod 256);
1223
 
1224
      else
1225
         Name_Buffer (Name_Len) := 'W';
1226
         Name_Len := Name_Len + 1;
1227
         Name_Buffer (Name_Len) := 'W';
1228
         Set_Hex_Chars (C / 2 ** 24);
1229
         Set_Hex_Chars ((C / 2 ** 16) mod 256);
1230
         Set_Hex_Chars ((C / 256) mod 256);
1231
         Set_Hex_Chars (C mod 256);
1232
      end if;
1233
   end Store_Encoded_Character;
1234
 
1235
   --------------------------------------
1236
   -- Strip_Qualification_And_Suffixes --
1237
   --------------------------------------
1238
 
1239
   procedure Strip_Qualification_And_Suffixes is
1240
      J : Integer;
1241
 
1242
   begin
1243
      --  Strip package body qualification string off end
1244
 
1245
      for J in reverse 2 .. Name_Len loop
1246
         if Name_Buffer (J) = 'X' then
1247
            Name_Len := J - 1;
1248
            exit;
1249
         end if;
1250
 
1251
         exit when Name_Buffer (J) /= 'b'
1252
           and then Name_Buffer (J) /= 'n'
1253
           and then Name_Buffer (J) /= 'p';
1254
      end loop;
1255
 
1256
      --  Find rightmost __ or $ separator if one exists. First we position
1257
      --  to start the search. If we have a character constant, position
1258
      --  just before it, otherwise position to last character but one
1259
 
1260
      if Name_Buffer (Name_Len) = ''' then
1261
         J := Name_Len - 2;
1262
         while J > 0 and then Name_Buffer (J) /= ''' loop
1263
            J := J - 1;
1264
         end loop;
1265
 
1266
      else
1267
         J := Name_Len - 1;
1268
      end if;
1269
 
1270
      --  Loop to search for rightmost __ or $ (homonym) separator
1271
 
1272
      while J > 1 loop
1273
 
1274
         --  If $ separator, homonym separator, so strip it and keep looking
1275
 
1276
         if Name_Buffer (J) = '$' then
1277
            Name_Len := J - 1;
1278
            J := Name_Len - 1;
1279
 
1280
         --  Else check for __ found
1281
 
1282
         elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1283
 
1284
            --  Found __ so see if digit follows, and if so, this is a
1285
            --  homonym separator, so strip it and keep looking.
1286
 
1287
            if Name_Buffer (J + 2) in '0' .. '9' then
1288
               Name_Len := J - 1;
1289
               J := Name_Len - 1;
1290
 
1291
            --  If not a homonym separator, then we simply strip the
1292
            --  separator and everything that precedes it, and we are done
1293
 
1294
            else
1295
               Name_Buffer (1 .. Name_Len - J - 1) :=
1296
                 Name_Buffer (J + 2 .. Name_Len);
1297
               Name_Len := Name_Len - J - 1;
1298
               exit;
1299
            end if;
1300
 
1301
         else
1302
            J := J - 1;
1303
         end if;
1304
      end loop;
1305
   end Strip_Qualification_And_Suffixes;
1306
 
1307
   ---------------
1308
   -- Tree_Read --
1309
   ---------------
1310
 
1311
   procedure Tree_Read is
1312
   begin
1313
      Name_Chars.Tree_Read;
1314
      Name_Entries.Tree_Read;
1315
 
1316
      Tree_Read_Data
1317
        (Hash_Table'Address,
1318
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1319
   end Tree_Read;
1320
 
1321
   ----------------
1322
   -- Tree_Write --
1323
   ----------------
1324
 
1325
   procedure Tree_Write is
1326
   begin
1327
      Name_Chars.Tree_Write;
1328
      Name_Entries.Tree_Write;
1329
 
1330
      Tree_Write_Data
1331
        (Hash_Table'Address,
1332
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1333
   end Tree_Write;
1334
 
1335
   ------------
1336
   -- Unlock --
1337
   ------------
1338
 
1339
   procedure Unlock is
1340
   begin
1341
      Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1342
      Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1343
      Name_Chars.Locked := False;
1344
      Name_Entries.Locked := False;
1345
      Name_Chars.Release;
1346
      Name_Entries.Release;
1347
   end Unlock;
1348
 
1349
   --------
1350
   -- wn --
1351
   --------
1352
 
1353
   procedure wn (Id : Name_Id) is
1354
      S : Int;
1355
 
1356
   begin
1357
      if not Id'Valid then
1358
         Write_Str ("<invalid name_id>");
1359
 
1360
      elsif Id = No_Name then
1361
         Write_Str ("<No_Name>");
1362
 
1363
      elsif Id = Error_Name then
1364
         Write_Str ("<Error_Name>");
1365
 
1366
      else
1367
         S := Name_Entries.Table (Id).Name_Chars_Index;
1368
         Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1369
 
1370
         for J in 1 .. Name_Len loop
1371
            Write_Char (Name_Chars.Table (S + Int (J)));
1372
         end loop;
1373
      end if;
1374
 
1375
      Write_Eol;
1376
   end wn;
1377
 
1378
   ----------------
1379
   -- Write_Name --
1380
   ----------------
1381
 
1382
   procedure Write_Name (Id : Name_Id) is
1383
   begin
1384
      if Id >= First_Name_Id then
1385
         Get_Name_String (Id);
1386
         Write_Str (Name_Buffer (1 .. Name_Len));
1387
      end if;
1388
   end Write_Name;
1389
 
1390
   ------------------------
1391
   -- Write_Name_Decoded --
1392
   ------------------------
1393
 
1394
   procedure Write_Name_Decoded (Id : Name_Id) is
1395
   begin
1396
      if Id >= First_Name_Id then
1397
         Get_Decoded_Name_String (Id);
1398
         Write_Str (Name_Buffer (1 .. Name_Len));
1399
      end if;
1400
   end Write_Name_Decoded;
1401
 
1402
end Namet;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.