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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [namet.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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