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 ------------------------------------------------------------------------------
34 with Types; use Types;
36 package body Snames is
38 -- Table used to record convention identifiers
40 type Convention_Id_Entry is record
42 Convention : Convention_Id;
45 package Convention_Identifiers is new Table.Table (
46 Table_Component_Type => Convention_Id_Entry,
47 Table_Index_Type => Int,
50 Table_Increment => 200,
51 Table_Name => "Name_Convention_Identifiers");
53 -- Table of names to be set by Initialize. Each name is terminated by a
54 -- single #, and the end of the list is marked by a null entry, i.e. by
55 -- two # marks in succession. Note that the table does not include the
56 -- entries for a-z, since these are initialized by Namet itself.
58 Preset_Names : constant String :=
59 !! TEMPLATE INSERTION POINT
66 -- This section lists the various cases of generated names which are
67 -- built from existing names by adding unique leading and/or trailing
68 -- upper case letters. In some cases these names are built recursively,
69 -- in particular names built from types may be built from types which
70 -- themselves have generated names. In this list, xxx represents an
71 -- existing name to which identifying letters are prepended or appended,
72 -- and a trailing n represents a serial number in an external name that
73 -- has some semantic significance (e.g. the n'th index type of an array).
75 -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
76 -- xxxB tag table for tagged type xxx (Exp_Ch3)
77 -- xxxB task body procedure for task xxx (Exp_Ch9)
78 -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
79 -- xxxD discriminal for discriminant xxx (Sem_Ch3)
80 -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
81 -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
82 -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
83 -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
84 -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
85 -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
86 -- xxxM master Id value for access type xxx (Exp_Ch3)
87 -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
88 -- xxxP parameter record type for entry xxx (Exp_Ch9)
89 -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
90 -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
91 -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
92 -- xxxT tag table type for tagged type xxx (Exp_Ch3)
93 -- xxxT literal table for enumeration type xxx (Sem_Ch3)
94 -- xxxV type for task value record for task xxx (Exp_Ch9)
95 -- xxxX entry index constant (Exp_Ch9)
96 -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
97 -- xxxZ size variable for task xxx (Exp_Ch9)
101 -- xxxDA deep adjust routine for type xxx (Exp_TSS)
102 -- xxxDF deep finalize routine for type xxx (Exp_TSS)
103 -- xxxDI deep initialize routine for type xxx (Exp_TSS)
104 -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
105 -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
106 -- xxxIP initialization procedure for type xxx (Exp_TSS)
107 -- xxxRA RAS type access routine for type xxx (Exp_TSS)
108 -- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
109 -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
110 -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
111 -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
112 -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
113 -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
114 -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
115 -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
116 -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
118 -- Implicit type names
120 -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
122 -- (Note: this list is not complete or accurate ???)
124 ----------------------
125 -- Get_Attribute_Id --
126 ----------------------
128 function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
131 return Attribute_CPU;
132 elsif N = Name_Dispatching_Domain then
133 return Attribute_Dispatching_Domain;
134 elsif N = Name_Interrupt_Priority then
135 return Attribute_Interrupt_Priority;
137 return Attribute_Id'Val (N - First_Attribute_Name);
139 end Get_Attribute_Id;
141 -----------------------
142 -- Get_Convention_Id --
143 -----------------------
145 function Get_Convention_Id (N : Name_Id) return Convention_Id is
148 when Name_Ada => return Convention_Ada;
149 when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy;
150 when Name_Ada_Pass_By_Reference => return
151 Convention_Ada_Pass_By_Reference;
152 when Name_Assembler => return Convention_Assembler;
153 when Name_C => return Convention_C;
154 when Name_CIL => return Convention_CIL;
155 when Name_COBOL => return Convention_COBOL;
156 when Name_CPP => return Convention_CPP;
157 when Name_Fortran => return Convention_Fortran;
158 when Name_Ghost => return Convention_Ghost;
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_Ghost => return Name_Ghost;
197 when Convention_Intrinsic => return Name_Intrinsic;
198 when Convention_Java => return Name_Java;
199 when Convention_Protected => return Name_Protected;
200 when Convention_Stdcall => return Name_Stdcall;
201 when Convention_Stubbed => return Name_Stubbed;
203 end Get_Convention_Name;
205 ---------------------------
206 -- Get_Locking_Policy_Id --
207 ---------------------------
209 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
211 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
212 end Get_Locking_Policy_Id;
218 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
220 if N = Name_AST_Entry then
221 return Pragma_AST_Entry;
222 elsif N = Name_CPU then
224 elsif N = Name_Dispatching_Domain then
225 return Pragma_Dispatching_Domain;
226 elsif N = Name_Fast_Math then
227 return Pragma_Fast_Math;
228 elsif N = Name_Interface then
229 return Pragma_Interface;
230 elsif N = Name_Interrupt_Priority then
231 return Pragma_Interrupt_Priority;
232 elsif N = Name_Lock_Free then
233 return Pragma_Lock_Free;
234 elsif N = Name_Priority then
235 return Pragma_Priority;
236 elsif N = Name_Relative_Deadline then
237 return Pragma_Relative_Deadline;
238 elsif N = Name_Storage_Size then
239 return Pragma_Storage_Size;
240 elsif N = Name_Storage_Unit then
241 return Pragma_Storage_Unit;
242 elsif N not in First_Pragma_Name .. Last_Pragma_Name then
243 return Unknown_Pragma;
245 return Pragma_Id'Val (N - First_Pragma_Name);
249 ---------------------------
250 -- Get_Queuing_Policy_Id --
251 ---------------------------
253 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
255 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
256 end Get_Queuing_Policy_Id;
258 ------------------------------------
259 -- Get_Task_Dispatching_Policy_Id --
260 ------------------------------------
262 function Get_Task_Dispatching_Policy_Id
263 (N : Name_Id) return Task_Dispatching_Policy_Id
266 return Task_Dispatching_Policy_Id'Val
267 (N - First_Task_Dispatching_Policy_Name);
268 end Get_Task_Dispatching_Policy_Id;
274 procedure Initialize is
276 Discard_Name : Name_Id;
279 P_Index := Preset_Names'First;
282 while Preset_Names (P_Index) /= '#' loop
283 Name_Len := Name_Len + 1;
284 Name_Buffer (Name_Len) := Preset_Names (P_Index);
285 P_Index := P_Index + 1;
288 -- We do the Name_Find call to enter the name into the table, but
289 -- we don't need to do anything with the result, since we already
290 -- initialized all the preset names to have the right value (we
291 -- are depending on the order of the names and Preset_Names).
293 Discard_Name := Name_Find;
294 P_Index := P_Index + 1;
295 exit when Preset_Names (P_Index) = '#';
298 -- Make sure that number of names in standard table is correct. If this
299 -- check fails, run utility program XSNAMES to construct a new properly
300 -- matching version of the body.
302 pragma Assert (Discard_Name = Last_Predefined_Name);
304 -- Initialize the convention identifiers table with the standard set of
305 -- synonyms that we recognize for conventions.
307 Convention_Identifiers.Init;
309 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
310 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
312 Convention_Identifiers.Append ((Name_Default, Convention_C));
313 Convention_Identifiers.Append ((Name_External, Convention_C));
315 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
317 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
318 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
321 -----------------------
322 -- Is_Attribute_Name --
323 -----------------------
325 function Is_Attribute_Name (N : Name_Id) return Boolean is
327 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name
328 -- unless we are working in CodePeer mode.
330 return N in First_Attribute_Name .. Last_Attribute_Name
331 and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body);
332 end Is_Attribute_Name;
334 ----------------------------------
335 -- Is_Configuration_Pragma_Name --
336 ----------------------------------
338 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
340 return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
341 or else N = Name_Fast_Math;
342 end Is_Configuration_Pragma_Name;
344 ------------------------
345 -- Is_Convention_Name --
346 ------------------------
348 function Is_Convention_Name (N : Name_Id) return Boolean is
350 -- Check if this is one of the standard conventions
352 if N in First_Convention_Name .. Last_Convention_Name
357 -- Otherwise check if it is in convention identifier table
360 for J in 1 .. Convention_Identifiers.Last loop
361 if N = Convention_Identifiers.Table (J).Name then
368 end Is_Convention_Name;
370 ------------------------------
371 -- Is_Entity_Attribute_Name --
372 ------------------------------
374 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
376 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
377 end Is_Entity_Attribute_Name;
379 --------------------------------
380 -- Is_Function_Attribute_Name --
381 --------------------------------
383 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
386 First_Renamable_Function_Attribute ..
387 Last_Renamable_Function_Attribute;
388 end Is_Function_Attribute_Name;
390 ---------------------
391 -- Is_Keyword_Name --
392 ---------------------
394 function Is_Keyword_Name (N : Name_Id) return Boolean is
396 return Get_Name_Table_Byte (N) /= 0
397 and then (Ada_Version >= Ada_95
398 or else N not in Ada_95_Reserved_Words)
399 and then (Ada_Version >= Ada_2005
400 or else N not in Ada_2005_Reserved_Words)
401 and then (Ada_Version >= Ada_2012
402 or else N not in Ada_2012_Reserved_Words);
405 --------------------------------
406 -- Is_Internal_Attribute_Name --
407 --------------------------------
409 function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
412 N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
413 end Is_Internal_Attribute_Name;
415 ----------------------------
416 -- Is_Locking_Policy_Name --
417 ----------------------------
419 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
421 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
422 end Is_Locking_Policy_Name;
424 -------------------------------------
425 -- Is_Partition_Elaboration_Policy --
426 -------------------------------------
428 function Is_Partition_Elaboration_Policy_Name
429 (N : Name_Id) return Boolean
432 return N in First_Partition_Elaboration_Policy_Name ..
433 Last_Partition_Elaboration_Policy_Name;
434 end Is_Partition_Elaboration_Policy_Name;
436 -----------------------------
437 -- Is_Operator_Symbol_Name --
438 -----------------------------
440 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
442 return N in First_Operator_Name .. Last_Operator_Name;
443 end Is_Operator_Symbol_Name;
449 function Is_Pragma_Name (N : Name_Id) return Boolean is
451 return N in First_Pragma_Name .. Last_Pragma_Name
452 or else N = Name_AST_Entry
454 or else N = Name_Dispatching_Domain
455 or else N = Name_Fast_Math
456 or else N = Name_Interface
457 or else N = Name_Interrupt_Priority
458 or else N = Name_Lock_Free
459 or else N = Name_Relative_Deadline
460 or else N = Name_Priority
461 or else N = Name_Storage_Size
462 or else N = Name_Storage_Unit;
465 ---------------------------------
466 -- Is_Procedure_Attribute_Name --
467 ---------------------------------
469 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
471 return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
472 end Is_Procedure_Attribute_Name;
474 ----------------------------
475 -- Is_Queuing_Policy_Name --
476 ----------------------------
478 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
480 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
481 end Is_Queuing_Policy_Name;
483 -------------------------------------
484 -- Is_Task_Dispatching_Policy_Name --
485 -------------------------------------
487 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
489 return N in First_Task_Dispatching_Policy_Name ..
490 Last_Task_Dispatching_Policy_Name;
491 end Is_Task_Dispatching_Policy_Name;
493 ----------------------------
494 -- Is_Type_Attribute_Name --
495 ----------------------------
497 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
499 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
500 end Is_Type_Attribute_Name;
502 ----------------------------------
503 -- Record_Convention_Identifier --
504 ----------------------------------
506 procedure Record_Convention_Identifier
508 Convention : Convention_Id)
511 Convention_Identifiers.Append ((Id, Convention));
512 end Record_Convention_Identifier;