1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Debug; use Debug;
35 with Types; use Types;
37 package body Snames is
39 -- Table used to record convention identifiers
41 type Convention_Id_Entry is record
43 Convention : Convention_Id;
46 package Convention_Identifiers is new Table.Table (
47 Table_Component_Type => Convention_Id_Entry,
48 Table_Index_Type => Int,
51 Table_Increment => 200,
52 Table_Name => "Name_Convention_Identifiers");
54 -- Table of names to be set by Initialize. Each name is terminated by a
55 -- single #, and the end of the list is marked by a null entry, i.e. by
56 -- two # marks in succession. Note that the table does not include the
57 -- entries for a-z, since these are initialized by Namet itself.
59 Preset_Names : constant String :=
60 !! TEMPLATE INSERTION POINT
67 -- This section lists the various cases of generated names which are
68 -- built from existing names by adding unique leading and/or trailing
69 -- upper case letters. In some cases these names are built recursively,
70 -- in particular names built from types may be built from types which
71 -- themselves have generated names. In this list, xxx represents an
72 -- existing name to which identifying letters are prepended or appended,
73 -- and a trailing n represents a serial number in an external name that
74 -- has some semantic significance (e.g. the n'th index type of an array).
76 -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
77 -- xxxB tag table for tagged type xxx (Exp_Ch3)
78 -- xxxB task body procedure for task xxx (Exp_Ch9)
79 -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
80 -- xxxD discriminal for discriminant xxx (Sem_Ch3)
81 -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
82 -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
83 -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
84 -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
85 -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
86 -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
87 -- xxxM master Id value for access type xxx (Exp_Ch3)
88 -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
89 -- xxxP parameter record type for entry xxx (Exp_Ch9)
90 -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
91 -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
92 -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
93 -- xxxT tag table type for tagged type xxx (Exp_Ch3)
94 -- xxxT literal table for enumeration type xxx (Sem_Ch3)
95 -- xxxV type for task value record for task xxx (Exp_Ch9)
96 -- xxxX entry index constant (Exp_Ch9)
97 -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
98 -- xxxZ size variable for task xxx (Exp_Ch9)
102 -- xxxDA deep adjust routine for type xxx (Exp_TSS)
103 -- xxxDF deep finalize routine for type xxx (Exp_TSS)
104 -- xxxDI deep initialize routine for type xxx (Exp_TSS)
105 -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
106 -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
107 -- xxxIP initialization procedure for type xxx (Exp_TSS)
108 -- xxxRA RAS type access routine for type xxx (Exp_TSS)
109 -- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
110 -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
111 -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
112 -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
113 -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
114 -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
115 -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
116 -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
117 -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
119 -- Implicit type names
121 -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
123 -- (Note: this list is not complete or accurate ???)
125 ----------------------
126 -- Get_Attribute_Id --
127 ----------------------
129 function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
132 return Attribute_CPU;
133 elsif N = Name_Dispatching_Domain then
134 return Attribute_Dispatching_Domain;
135 elsif N = Name_Interrupt_Priority then
136 return Attribute_Interrupt_Priority;
138 return Attribute_Id'Val (N - First_Attribute_Name);
140 end Get_Attribute_Id;
142 -----------------------
143 -- Get_Convention_Id --
144 -----------------------
146 function Get_Convention_Id (N : Name_Id) return Convention_Id is
149 when Name_Ada => return Convention_Ada;
150 when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy;
151 when Name_Ada_Pass_By_Reference => return
152 Convention_Ada_Pass_By_Reference;
153 when Name_Assembler => return Convention_Assembler;
154 when Name_C => return Convention_C;
155 when Name_CIL => return Convention_CIL;
156 when Name_COBOL => return Convention_COBOL;
157 when Name_CPP => return Convention_CPP;
158 when Name_Fortran => return Convention_Fortran;
159 when Name_Intrinsic => return Convention_Intrinsic;
160 when Name_Java => return Convention_Java;
161 when Name_Stdcall => return Convention_Stdcall;
162 when Name_Stubbed => return Convention_Stubbed;
164 -- If no direct match, then we must have a convention
165 -- identifier pragma that has specified this name.
168 for J in 1 .. Convention_Identifiers.Last loop
169 if N = Convention_Identifiers.Table (J).Name then
170 return Convention_Identifiers.Table (J).Convention;
176 end Get_Convention_Id;
178 -------------------------
179 -- Get_Convention_Name --
180 -------------------------
182 function Get_Convention_Name (C : Convention_Id) return Name_Id is
185 when Convention_Ada => return Name_Ada;
186 when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy;
187 when Convention_Ada_Pass_By_Reference =>
188 return Name_Ada_Pass_By_Reference;
189 when Convention_Assembler => return Name_Assembler;
190 when Convention_C => return Name_C;
191 when Convention_CIL => return Name_CIL;
192 when Convention_COBOL => return Name_COBOL;
193 when Convention_CPP => return Name_CPP;
194 when Convention_Entry => return Name_Entry;
195 when Convention_Fortran => return Name_Fortran;
196 when Convention_Intrinsic => return Name_Intrinsic;
197 when Convention_Java => return Name_Java;
198 when Convention_Protected => return Name_Protected;
199 when Convention_Stdcall => return Name_Stdcall;
200 when Convention_Stubbed => return Name_Stubbed;
202 end Get_Convention_Name;
204 ---------------------------
205 -- Get_Locking_Policy_Id --
206 ---------------------------
208 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
210 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
211 end Get_Locking_Policy_Id;
217 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
222 when Name_Default_Scalar_Storage_Order =>
223 return Pragma_Default_Scalar_Storage_Order;
224 when Name_Dispatching_Domain =>
225 return Pragma_Dispatching_Domain;
226 when Name_Fast_Math =>
227 return Pragma_Fast_Math;
228 when Name_Interface =>
229 return Pragma_Interface;
230 when Name_Interrupt_Priority =>
231 return Pragma_Interrupt_Priority;
232 when Name_Lock_Free =>
233 return Pragma_Lock_Free;
234 when Name_Priority =>
235 return Pragma_Priority;
236 when Name_Storage_Size =>
237 return Pragma_Storage_Size;
238 when Name_Storage_Unit =>
239 return Pragma_Storage_Unit;
240 when First_Pragma_Name .. Last_Pragma_Name =>
241 return Pragma_Id'Val (N - First_Pragma_Name);
243 return Unknown_Pragma;
247 ---------------------------
248 -- Get_Queuing_Policy_Id --
249 ---------------------------
251 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
253 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
254 end Get_Queuing_Policy_Id;
256 ------------------------------------
257 -- Get_Task_Dispatching_Policy_Id --
258 ------------------------------------
260 function Get_Task_Dispatching_Policy_Id
261 (N : Name_Id) return Task_Dispatching_Policy_Id
264 return Task_Dispatching_Policy_Id'Val
265 (N - First_Task_Dispatching_Policy_Name);
266 end Get_Task_Dispatching_Policy_Id;
272 procedure Initialize is
274 Discard_Name : Name_Id;
277 P_Index := Preset_Names'First;
280 while Preset_Names (P_Index) /= '#' loop
281 Name_Len := Name_Len + 1;
282 Name_Buffer (Name_Len) := Preset_Names (P_Index);
283 P_Index := P_Index + 1;
286 -- We do the Name_Find call to enter the name into the table, but
287 -- we don't need to do anything with the result, since we already
288 -- initialized all the preset names to have the right value (we
289 -- are depending on the order of the names and Preset_Names).
291 Discard_Name := Name_Find;
292 P_Index := P_Index + 1;
293 exit when Preset_Names (P_Index) = '#';
296 -- Make sure that number of names in standard table is correct. If this
297 -- check fails, run utility program XSNAMES to construct a new properly
298 -- matching version of the body.
300 pragma Assert (Discard_Name = Last_Predefined_Name);
302 -- Initialize the convention identifiers table with the standard set of
303 -- synonyms that we recognize for conventions.
305 Convention_Identifiers.Init;
307 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
308 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
310 Convention_Identifiers.Append ((Name_Default, Convention_C));
311 Convention_Identifiers.Append ((Name_External, Convention_C));
313 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
315 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
316 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
319 -----------------------
320 -- Is_Attribute_Name --
321 -----------------------
323 function Is_Attribute_Name (N : Name_Id) return Boolean is
325 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name
326 -- unless we are working in CodePeer mode.
328 return N in First_Attribute_Name .. Last_Attribute_Name
329 and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body);
330 end Is_Attribute_Name;
332 ----------------------------------
333 -- Is_Configuration_Pragma_Name --
334 ----------------------------------
336 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
338 return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
339 or else N = Name_Default_Scalar_Storage_Order
340 or else N = Name_Fast_Math;
341 end Is_Configuration_Pragma_Name;
343 ------------------------
344 -- Is_Convention_Name --
345 ------------------------
347 function Is_Convention_Name (N : Name_Id) return Boolean is
349 -- Check if this is one of the standard conventions
351 if N in First_Convention_Name .. Last_Convention_Name
356 -- Otherwise check if it is in convention identifier table
359 for J in 1 .. Convention_Identifiers.Last loop
360 if N = Convention_Identifiers.Table (J).Name then
367 end Is_Convention_Name;
369 ------------------------------
370 -- Is_Entity_Attribute_Name --
371 ------------------------------
373 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
375 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
376 end Is_Entity_Attribute_Name;
378 --------------------------------
379 -- Is_Function_Attribute_Name --
380 --------------------------------
382 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
385 First_Renamable_Function_Attribute ..
386 Last_Renamable_Function_Attribute;
387 end Is_Function_Attribute_Name;
389 ---------------------
390 -- Is_Keyword_Name --
391 ---------------------
393 function Is_Keyword_Name (N : Name_Id) return Boolean is
395 return Get_Name_Table_Byte (N) /= 0
396 and then (Ada_Version >= Ada_95
397 or else N not in Ada_95_Reserved_Words)
398 and then (Ada_Version >= Ada_2005
399 or else N not in Ada_2005_Reserved_Words
400 or else (Debug_Flag_Dot_DD and then N = Name_Overriding))
401 -- Accept 'overriding' keywords if -gnatd.D is used,
402 -- for compatibility with Ada 95 compilers implementing
403 -- only this Ada 2005 extension.
404 and then (Ada_Version >= Ada_2012
405 or else N not in Ada_2012_Reserved_Words);
408 --------------------------------
409 -- Is_Internal_Attribute_Name --
410 --------------------------------
412 function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
415 N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
416 end Is_Internal_Attribute_Name;
418 ----------------------------
419 -- Is_Locking_Policy_Name --
420 ----------------------------
422 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
424 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
425 end Is_Locking_Policy_Name;
427 -------------------------------------
428 -- Is_Partition_Elaboration_Policy --
429 -------------------------------------
431 function Is_Partition_Elaboration_Policy_Name
432 (N : Name_Id) return Boolean
435 return N in First_Partition_Elaboration_Policy_Name ..
436 Last_Partition_Elaboration_Policy_Name;
437 end Is_Partition_Elaboration_Policy_Name;
439 -----------------------------
440 -- Is_Operator_Symbol_Name --
441 -----------------------------
443 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
445 return N in First_Operator_Name .. Last_Operator_Name;
446 end Is_Operator_Symbol_Name;
452 function Is_Pragma_Name (N : Name_Id) return Boolean is
454 return N in First_Pragma_Name .. Last_Pragma_Name
456 or else N = Name_Default_Scalar_Storage_Order
457 or else N = Name_Dispatching_Domain
458 or else N = Name_Fast_Math
459 or else N = Name_Interface
460 or else N = Name_Interrupt_Priority
461 or else N = Name_Lock_Free
462 or else N = Name_Relative_Deadline
463 or else N = Name_Priority
464 or else N = Name_Storage_Size
465 or else N = Name_Storage_Unit;
468 ---------------------------------
469 -- Is_Procedure_Attribute_Name --
470 ---------------------------------
472 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
474 return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
475 end Is_Procedure_Attribute_Name;
477 ----------------------------
478 -- Is_Queuing_Policy_Name --
479 ----------------------------
481 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
483 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
484 end Is_Queuing_Policy_Name;
486 -------------------------------------
487 -- Is_Task_Dispatching_Policy_Name --
488 -------------------------------------
490 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
492 return N in First_Task_Dispatching_Policy_Name ..
493 Last_Task_Dispatching_Policy_Name;
494 end Is_Task_Dispatching_Policy_Name;
496 ----------------------------
497 -- Is_Type_Attribute_Name --
498 ----------------------------
500 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
502 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
503 end Is_Type_Attribute_Name;
505 ----------------------------------
506 -- Record_Convention_Identifier --
507 ----------------------------------
509 procedure Record_Convention_Identifier
511 Convention : Convention_Id)
514 Convention_Identifiers.Append ((Id, Convention));
515 end Record_Convention_Identifier;