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