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