| blob | 9b087e6cd62c80a8c22d595c67c5fd30263f6d25 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S N A M E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Debug; use Debug;
27 with Opt; use Opt;
28 with Table;
29 with Types; use Types;
31 package body Snames is
33 -- Table used to record convention identifiers
35 type Convention_Id_Entry is record
36 Name : Name_Id;
37 Convention : Convention_Id;
38 end record;
40 package Convention_Identifiers is new Table.Table (
41 Table_Component_Type => Convention_Id_Entry,
42 Table_Index_Type => Int,
43 Table_Low_Bound => 1,
44 Table_Initial => 50,
45 Table_Increment => 200,
46 Table_Name => "Name_Convention_Identifiers");
48 -- Table of names to be set by Initialize. Each name is terminated by a
49 -- single #, and the end of the list is marked by a null entry, i.e. by
50 -- two # marks in succession. Note that the table does not include the
51 -- entries for a-z, since these are initialized by Namet itself.
53 Preset_Names : constant String :=
54 !! TEMPLATE INSERTION POINT
55 "#";
57 ---------------------
58 -- Generated Names --
59 ---------------------
61 -- This section lists the various cases of generated names which are
62 -- built from existing names by adding unique leading and/or trailing
63 -- upper case letters. In some cases these names are built recursively,
64 -- in particular names built from types may be built from types which
65 -- themselves have generated names. In this list, xxx represents an
66 -- existing name to which identifying letters are prepended or appended,
67 -- and a trailing n represents a serial number in an external name that
68 -- has some semantic significance (e.g. the n'th index type of an array).
70 -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
71 -- xxxB tag table for tagged type xxx (Exp_Ch3)
72 -- xxxB task body procedure for task xxx (Exp_Ch9)
73 -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
74 -- xxxD discriminal for discriminant xxx (Sem_Ch3)
75 -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
76 -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
77 -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
78 -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
79 -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
80 -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
81 -- xxxM master Id value for access type xxx (Exp_Ch3)
82 -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
83 -- xxxP parameter record type for entry xxx (Exp_Ch9)
84 -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
85 -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
86 -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
87 -- xxxT tag table type for tagged type xxx (Exp_Ch3)
88 -- xxxT literal table for enumeration type xxx (Sem_Ch3)
89 -- xxxV type for task value record for task xxx (Exp_Ch9)
90 -- xxxX entry index constant (Exp_Ch9)
91 -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
92 -- xxxZ size variable for task xxx (Exp_Ch9)
94 -- TSS names
96 -- xxxDA deep adjust routine for type xxx (Exp_TSS)
97 -- xxxDF deep finalize routine for type xxx (Exp_TSS)
98 -- xxxDI deep initialize routine for type xxx (Exp_TSS)
99 -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
100 -- xxxFD finalize address routine for type xxx (Exp_TSS)
101 -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
102 -- xxxIP initialization procedure for type xxx (Exp_TSS)
103 -- xxxIC init C++ dispatch tables procedure for type xxx (Exp_TSS)
104 -- xxxRA RAS type access routine for type xxx (Exp_TSS)
105 -- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
106 -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
107 -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
108 -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
109 -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
110 -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
111 -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
112 -- xxxPI Put_Image attribute subprogram for type xxx (Exp_TSS)
113 -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
114 -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
116 -- Implicit type names
118 -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
120 -- (Note: this list is not complete or accurate ???)
122 ----------------------
123 -- Get_Attribute_Id --
124 ----------------------
126 function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
127 begin
128 if N = Name_CPU then
129 return Attribute_CPU;
130 elsif N = Name_Dispatching_Domain then
131 return Attribute_Dispatching_Domain;
132 elsif N = Name_Interrupt_Priority then
133 return Attribute_Interrupt_Priority;
134 else
135 return Attribute_Id'Val (N - First_Attribute_Name);
136 end if;
137 end Get_Attribute_Id;
139 -----------------------
140 -- Get_Convention_Id --
141 -----------------------
143 function Get_Convention_Id (N : Name_Id) return Convention_Id is
144 begin
145 case N is
146 when Name_Ada => return Convention_Ada;
147 when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy;
148 when Name_Ada_Pass_By_Reference => return
149 Convention_Ada_Pass_By_Reference;
150 when Name_Assembler => return Convention_Assembler;
151 when Name_C => return Convention_C;
152 when Name_C_Variadic_0 => return Convention_C_Variadic_0;
153 when Name_C_Variadic_1 => return Convention_C_Variadic_1;
154 when Name_C_Variadic_2 => return Convention_C_Variadic_2;
155 when Name_C_Variadic_3 => return Convention_C_Variadic_3;
156 when Name_C_Variadic_4 => return Convention_C_Variadic_4;
157 when Name_C_Variadic_5 => return Convention_C_Variadic_5;
158 when Name_C_Variadic_6 => return Convention_C_Variadic_6;
159 when Name_C_Variadic_7 => return Convention_C_Variadic_7;
160 when Name_C_Variadic_8 => return Convention_C_Variadic_8;
161 when Name_C_Variadic_9 => return Convention_C_Variadic_9;
162 when Name_C_Variadic_10 => return Convention_C_Variadic_10;
163 when Name_C_Variadic_11 => return Convention_C_Variadic_11;
164 when Name_C_Variadic_12 => return Convention_C_Variadic_12;
165 when Name_C_Variadic_13 => return Convention_C_Variadic_13;
166 when Name_C_Variadic_14 => return Convention_C_Variadic_14;
167 when Name_C_Variadic_15 => return Convention_C_Variadic_15;
168 when Name_C_Variadic_16 => return Convention_C_Variadic_16;
169 when Name_COBOL => return Convention_COBOL;
170 when Name_CPP => return Convention_CPP;
171 when Name_Fortran => return Convention_Fortran;
172 when Name_Intrinsic => return Convention_Intrinsic;
173 when Name_Stdcall => return Convention_Stdcall;
174 when Name_Stubbed => return Convention_Stubbed;
176 -- If no direct match, then we must have a convention
177 -- identifier pragma that has specified this name.
179 when others =>
180 for J in 1 .. Convention_Identifiers.Last loop
181 if N = Convention_Identifiers.Table (J).Name then
182 return Convention_Identifiers.Table (J).Convention;
183 end if;
184 end loop;
186 raise Program_Error;
187 end case;
188 end Get_Convention_Id;
190 -------------------------
191 -- Get_Convention_Name --
192 -------------------------
194 function Get_Convention_Name (C : Convention_Id) return Name_Id is
195 begin
196 case C is
197 when Convention_Ada => return Name_Ada;
198 when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy;
199 when Convention_Ada_Pass_By_Reference =>
200 return Name_Ada_Pass_By_Reference;
201 when Convention_Assembler => return Name_Assembler;
202 when Convention_C => return Name_C;
203 when Convention_C_Variadic_0 => return Name_C_Variadic_0;
204 when Convention_C_Variadic_1 => return Name_C_Variadic_1;
205 when Convention_C_Variadic_2 => return Name_C_Variadic_2;
206 when Convention_C_Variadic_3 => return Name_C_Variadic_3;
207 when Convention_C_Variadic_4 => return Name_C_Variadic_4;
208 when Convention_C_Variadic_5 => return Name_C_Variadic_5;
209 when Convention_C_Variadic_6 => return Name_C_Variadic_6;
210 when Convention_C_Variadic_7 => return Name_C_Variadic_7;
211 when Convention_C_Variadic_8 => return Name_C_Variadic_8;
212 when Convention_C_Variadic_9 => return Name_C_Variadic_9;
213 when Convention_C_Variadic_10 => return Name_C_Variadic_10;
214 when Convention_C_Variadic_11 => return Name_C_Variadic_11;
215 when Convention_C_Variadic_12 => return Name_C_Variadic_12;
216 when Convention_C_Variadic_13 => return Name_C_Variadic_13;
217 when Convention_C_Variadic_14 => return Name_C_Variadic_14;
218 when Convention_C_Variadic_15 => return Name_C_Variadic_15;
219 when Convention_C_Variadic_16 => return Name_C_Variadic_16;
220 when Convention_COBOL => return Name_COBOL;
221 when Convention_CPP => return Name_CPP;
222 when Convention_Entry => return Name_Entry;
223 when Convention_Fortran => return Name_Fortran;
224 when Convention_Intrinsic => return Name_Intrinsic;
225 when Convention_Protected => return Name_Protected;
226 when Convention_Stdcall => return Name_Stdcall;
227 when Convention_Stubbed => return Name_Stubbed;
228 end case;
229 end Get_Convention_Name;
231 ---------------------------
232 -- Get_Locking_Policy_Id --
233 ---------------------------
235 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
236 begin
237 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
238 end Get_Locking_Policy_Id;
240 -------------------
241 -- Get_Pragma_Id --
242 -------------------
244 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
245 begin
246 case N is
247 when Name_CPU =>
248 return Pragma_CPU;
249 when Name_Default_Scalar_Storage_Order =>
250 return Pragma_Default_Scalar_Storage_Order;
251 when Name_Dispatching_Domain =>
252 return Pragma_Dispatching_Domain;
253 when Name_Fast_Math =>
254 return Pragma_Fast_Math;
255 when Name_Interface =>
256 return Pragma_Interface;
257 when Name_Interrupt_Priority =>
258 return Pragma_Interrupt_Priority;
259 when Name_Preelaborable_Initialization =>
260 return Pragma_Preelaborable_Initialization;
261 when Name_Priority =>
262 return Pragma_Priority;
263 when Name_Secondary_Stack_Size =>
264 return Pragma_Secondary_Stack_Size;
265 when Name_Storage_Size =>
266 return Pragma_Storage_Size;
267 when Name_Storage_Unit =>
268 return Pragma_Storage_Unit;
269 when First_Pragma_Name .. Last_Pragma_Name =>
270 return Pragma_Id'Val (N - First_Pragma_Name);
271 when others =>
272 return Unknown_Pragma;
273 end case;
274 end Get_Pragma_Id;
276 ---------------------------
277 -- Get_Queuing_Policy_Id --
278 ---------------------------
280 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
281 begin
282 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
283 end Get_Queuing_Policy_Id;
285 ------------------------------------
286 -- Get_Task_Dispatching_Policy_Id --
287 ------------------------------------
289 function Get_Task_Dispatching_Policy_Id
290 (N : Name_Id) return Task_Dispatching_Policy_Id
291 is
292 begin
293 return Task_Dispatching_Policy_Id'Val
294 (N - First_Task_Dispatching_Policy_Name);
295 end Get_Task_Dispatching_Policy_Id;
297 ----------------
298 -- Initialize --
299 ----------------
301 procedure Initialize is
302 P_Index : Natural;
303 Discard_Name : Name_Id;
305 begin
306 P_Index := Preset_Names'First;
307 loop
308 Name_Len := 0;
309 while Preset_Names (P_Index) /= '#' loop
310 Name_Len := Name_Len + 1;
311 Name_Buffer (Name_Len) := Preset_Names (P_Index);
312 P_Index := P_Index + 1;
313 end loop;
315 -- We do the Name_Find call to enter the name into the table, but
316 -- we don't need to do anything with the result, since we already
317 -- initialized all the preset names to have the right value (we
318 -- are depending on the order of the names and Preset_Names).
320 Discard_Name := Name_Find;
321 P_Index := P_Index + 1;
322 exit when Preset_Names (P_Index) = '#';
323 end loop;
325 -- Make sure that number of names in standard table is correct. If this
326 -- check fails, run utility program XSNAMES to construct a new properly
327 -- matching version of the body.
329 pragma Assert (Discard_Name = Last_Predefined_Name);
331 -- Initialize the convention identifiers table with the standard set of
332 -- synonyms that we recognize for conventions.
334 Convention_Identifiers.Init;
336 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
337 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
339 Convention_Identifiers.Append ((Name_Default, Convention_C));
340 Convention_Identifiers.Append ((Name_External, Convention_C));
342 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
344 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
345 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
346 end Initialize;
348 -----------------------
349 -- Is_Attribute_Name --
350 -----------------------
352 function Is_Attribute_Name (N : Name_Id) return Boolean is
353 begin
354 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name
355 -- unless we are working in CodePeer mode.
357 return N in First_Attribute_Name .. Last_Attribute_Name
358 and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body);
359 end Is_Attribute_Name;
361 ----------------------------------
362 -- Is_Configuration_Pragma_Name --
363 ----------------------------------
365 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
366 begin
367 return N in Configuration_Pragma_Names
368 or else N = Name_Default_Scalar_Storage_Order
369 or else N = Name_Fast_Math;
370 end Is_Configuration_Pragma_Name;
372 ------------------------
373 -- Is_Convention_Name --
374 ------------------------
376 function Is_Convention_Name (N : Name_Id) return Boolean is
377 begin
378 -- Check if this is one of the standard conventions
380 if N in First_Convention_Name .. Last_Convention_Name
381 or else N = Name_C
382 then
383 return True;
385 -- Otherwise check if it is in convention identifier table
387 else
388 for J in 1 .. Convention_Identifiers.Last loop
389 if N = Convention_Identifiers.Table (J).Name then
390 return True;
391 end if;
392 end loop;
394 return False;
395 end if;
396 end Is_Convention_Name;
398 ------------------------------
399 -- Is_Entity_Attribute_Name --
400 ------------------------------
402 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
403 begin
404 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
405 end Is_Entity_Attribute_Name;
407 --------------------------------
408 -- Is_Function_Attribute_Name --
409 --------------------------------
411 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
412 begin
413 return N in
414 First_Renamable_Function_Attribute ..
415 Last_Renamable_Function_Attribute;
416 end Is_Function_Attribute_Name;
418 ---------------------
419 -- Is_Keyword_Name --
420 ---------------------
422 function Is_Keyword_Name (N : Name_Id) return Boolean is
423 begin
424 return Get_Name_Table_Byte (N) /= 0
425 and then (Ada_Version >= Ada_95
426 or else N not in Ada_95_Reserved_Words)
427 and then (Ada_Version >= Ada_2005
428 or else N not in Ada_2005_Reserved_Words
429 or else (Debug_Flag_Dot_DD and then N = Name_Overriding))
430 -- Accept 'overriding' keywords if -gnatd.D is used,
431 -- for compatibility with Ada 95 compilers implementing
432 -- only this Ada 2005 extension.
433 and then (Ada_Version >= Ada_2012
434 or else N not in Ada_2012_Reserved_Words);
435 end Is_Keyword_Name;
437 --------------------------------
438 -- Is_Internal_Attribute_Name --
439 --------------------------------
441 function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
442 begin
443 return
444 N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
445 end Is_Internal_Attribute_Name;
447 ----------------------------
448 -- Is_Locking_Policy_Name --
449 ----------------------------
451 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
452 begin
453 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
454 end Is_Locking_Policy_Name;
456 ------------------------------------------
457 -- Is_Partition_Elaboration_Policy_Name --
458 ------------------------------------------
460 function Is_Partition_Elaboration_Policy_Name
461 (N : Name_Id) return Boolean
462 is
463 begin
464 return N in First_Partition_Elaboration_Policy_Name ..
465 Last_Partition_Elaboration_Policy_Name;
466 end Is_Partition_Elaboration_Policy_Name;
468 -----------------------------
469 -- Is_Operator_Symbol_Name --
470 -----------------------------
472 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
473 begin
474 return N in First_Operator_Name .. Last_Operator_Name;
475 end Is_Operator_Symbol_Name;
477 --------------------
478 -- Is_Pragma_Name --
479 --------------------
481 function Is_Pragma_Name (N : Name_Id) return Boolean is
482 begin
483 return N in First_Pragma_Name .. Last_Pragma_Name
484 or else N = Name_CPU
485 or else N = Name_Default_Scalar_Storage_Order
486 or else N = Name_Dispatching_Domain
487 or else N = Name_Fast_Math
488 or else N = Name_Interface
489 or else N = Name_Interrupt_Priority
490 or else N = Name_Preelaborable_Initialization
491 or else N = Name_Priority
492 or else N = Name_Secondary_Stack_Size
493 or else N = Name_Storage_Size
494 or else N = Name_Storage_Unit;
495 end Is_Pragma_Name;
497 ---------------------------------
498 -- Is_Procedure_Attribute_Name --
499 ---------------------------------
501 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
502 begin
503 return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
504 end Is_Procedure_Attribute_Name;
506 ----------------------------
507 -- Is_Queuing_Policy_Name --
508 ----------------------------
510 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
511 begin
512 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
513 end Is_Queuing_Policy_Name;
515 -------------------------------------
516 -- Is_Task_Dispatching_Policy_Name --
517 -------------------------------------
519 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
520 begin
521 return N in First_Task_Dispatching_Policy_Name ..
522 Last_Task_Dispatching_Policy_Name;
523 end Is_Task_Dispatching_Policy_Name;
525 ----------------------------
526 -- Is_Type_Attribute_Name --
527 ----------------------------
529 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
530 begin
531 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
532 end Is_Type_Attribute_Name;
534 ----------------------------------
535 -- Record_Convention_Identifier --
536 ----------------------------------
538 procedure Record_Convention_Identifier
539 (Id : Name_Id;
540 Convention : Convention_Id)
541 is
542 begin
543 Convention_Identifiers.Append ((Id, Convention));
544 end Record_Convention_Identifier;
546 end Snames;