1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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
130 return Attribute_Id'Val (N - First_Attribute_Name);
131 end Get_Attribute_Id;
133 -----------------------
134 -- Get_Convention_Id --
135 -----------------------
137 function Get_Convention_Id (N : Name_Id) return Convention_Id is
140 when Name_Ada => return Convention_Ada;
141 when Name_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy;
142 when Name_Ada_Pass_By_Reference =>
143 return Convention_Ada_Pass_By_Reference;
144 when Name_Assembler => return Convention_Assembler;
145 when Name_C => return Convention_C;
146 when Name_CIL => return Convention_CIL;
147 when Name_COBOL => return Convention_COBOL;
148 when Name_CPP => return Convention_CPP;
149 when Name_Fortran => return Convention_Fortran;
150 when Name_Intrinsic => return Convention_Intrinsic;
151 when Name_Java => return Convention_Java;
152 when Name_Stdcall => return Convention_Stdcall;
153 when Name_Stubbed => return Convention_Stubbed;
155 -- If no direct match, then we must have a convention
156 -- identifier pragma that has specified this name.
159 for J in 1 .. Convention_Identifiers.Last loop
160 if N = Convention_Identifiers.Table (J).Name then
161 return Convention_Identifiers.Table (J).Convention;
167 end Get_Convention_Id;
169 -------------------------
170 -- Get_Convention_Name --
171 -------------------------
173 function Get_Convention_Name (C : Convention_Id) return Name_Id is
176 when Convention_Ada => return Name_Ada;
177 when Convention_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy;
178 when Convention_Ada_Pass_By_Reference =>
179 return Name_Ada_Pass_By_Reference;
180 when Convention_Assembler => return Name_Assembler;
181 when Convention_C => return Name_C;
182 when Convention_CIL => return Name_CIL;
183 when Convention_COBOL => return Name_COBOL;
184 when Convention_CPP => return Name_CPP;
185 when Convention_Entry => return Name_Entry;
186 when Convention_Fortran => return Name_Fortran;
187 when Convention_Intrinsic => return Name_Intrinsic;
188 when Convention_Java => return Name_Java;
189 when Convention_Protected => return Name_Protected;
190 when Convention_Stdcall => return Name_Stdcall;
191 when Convention_Stubbed => return Name_Stubbed;
193 end Get_Convention_Name;
195 ---------------------------
196 -- Get_Locking_Policy_Id --
197 ---------------------------
199 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
201 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
202 end Get_Locking_Policy_Id;
208 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
210 if N = Name_AST_Entry then
211 return Pragma_AST_Entry;
212 elsif N = Name_Fast_Math then
213 return Pragma_Fast_Math;
214 elsif N = Name_Interface then
215 return Pragma_Interface;
216 elsif N = Name_Priority then
217 return Pragma_Priority;
218 elsif N = Name_Relative_Deadline then
219 return Pragma_Relative_Deadline;
220 elsif N = Name_Storage_Size then
221 return Pragma_Storage_Size;
222 elsif N = Name_Storage_Unit then
223 return Pragma_Storage_Unit;
224 elsif N not in First_Pragma_Name .. Last_Pragma_Name then
225 return Unknown_Pragma;
227 return Pragma_Id'Val (N - First_Pragma_Name);
231 ---------------------------
232 -- Get_Queuing_Policy_Id --
233 ---------------------------
235 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
237 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
238 end Get_Queuing_Policy_Id;
240 ------------------------------------
241 -- Get_Task_Dispatching_Policy_Id --
242 ------------------------------------
244 function Get_Task_Dispatching_Policy_Id
245 (N : Name_Id) return Task_Dispatching_Policy_Id
248 return Task_Dispatching_Policy_Id'Val
249 (N - First_Task_Dispatching_Policy_Name);
250 end Get_Task_Dispatching_Policy_Id;
256 procedure Initialize is
258 Discard_Name : Name_Id;
261 P_Index := Preset_Names'First;
264 while Preset_Names (P_Index) /= '#' loop
265 Name_Len := Name_Len + 1;
266 Name_Buffer (Name_Len) := Preset_Names (P_Index);
267 P_Index := P_Index + 1;
270 -- We do the Name_Find call to enter the name into the table, but
271 -- we don't need to do anything with the result, since we already
272 -- initialized all the preset names to have the right value (we
273 -- are depending on the order of the names and Preset_Names).
275 Discard_Name := Name_Find;
276 P_Index := P_Index + 1;
277 exit when Preset_Names (P_Index) = '#';
280 -- Make sure that number of names in standard table is correct. If
281 -- this check fails, run utility program XSNAMES to construct a new
282 -- properly matching version of the body.
284 pragma Assert (Discard_Name = Last_Predefined_Name);
286 -- Initialize the convention identifiers table with the standard
287 -- set of synonyms that we recognize for conventions.
289 Convention_Identifiers.Init;
291 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
292 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
294 Convention_Identifiers.Append ((Name_Default, Convention_C));
295 Convention_Identifiers.Append ((Name_External, Convention_C));
297 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
299 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
300 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
303 -----------------------
304 -- Is_Attribute_Name --
305 -----------------------
307 function Is_Attribute_Name (N : Name_Id) return Boolean is
309 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name
310 -- unless we are working in CodePeer mode.
312 return N in First_Attribute_Name .. Last_Attribute_Name
313 and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body);
314 end Is_Attribute_Name;
316 ----------------------------------
317 -- Is_Configuration_Pragma_Name --
318 ----------------------------------
320 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
322 return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
323 or else N = Name_Fast_Math;
324 end Is_Configuration_Pragma_Name;
326 ------------------------
327 -- Is_Convention_Name --
328 ------------------------
330 function Is_Convention_Name (N : Name_Id) return Boolean is
332 -- Check if this is one of the standard conventions
334 if N in First_Convention_Name .. Last_Convention_Name
339 -- Otherwise check if it is in convention identifier table
342 for J in 1 .. Convention_Identifiers.Last loop
343 if N = Convention_Identifiers.Table (J).Name then
350 end Is_Convention_Name;
352 ------------------------------
353 -- Is_Entity_Attribute_Name --
354 ------------------------------
356 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
358 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
359 end Is_Entity_Attribute_Name;
361 --------------------------------
362 -- Is_Function_Attribute_Name --
363 --------------------------------
365 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
368 First_Renamable_Function_Attribute ..
369 Last_Renamable_Function_Attribute;
370 end Is_Function_Attribute_Name;
372 ---------------------
373 -- Is_Keyword_Name --
374 ---------------------
376 function Is_Keyword_Name (N : Name_Id) return Boolean is
378 return Get_Name_Table_Byte (N) /= 0
379 and then (Ada_Version >= Ada_95
380 or else N not in Ada_95_Reserved_Words)
381 and then (Ada_Version >= Ada_2005
382 or else N not in Ada_2005_Reserved_Words);
385 ----------------------------
386 -- Is_Locking_Policy_Name --
387 ----------------------------
389 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
391 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
392 end Is_Locking_Policy_Name;
394 -----------------------------
395 -- Is_Operator_Symbol_Name --
396 -----------------------------
398 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
400 return N in First_Operator_Name .. Last_Operator_Name;
401 end Is_Operator_Symbol_Name;
407 function Is_Pragma_Name (N : Name_Id) return Boolean is
409 return N in First_Pragma_Name .. Last_Pragma_Name
410 or else N = Name_AST_Entry
411 or else N = Name_Fast_Math
412 or else N = Name_Interface
413 or else N = Name_Relative_Deadline
414 or else N = Name_Priority
415 or else N = Name_Storage_Size
416 or else N = Name_Storage_Unit;
419 ---------------------------------
420 -- Is_Procedure_Attribute_Name --
421 ---------------------------------
423 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
425 return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
426 end Is_Procedure_Attribute_Name;
428 ----------------------------
429 -- Is_Queuing_Policy_Name --
430 ----------------------------
432 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
434 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
435 end Is_Queuing_Policy_Name;
437 -------------------------------------
438 -- Is_Task_Dispatching_Policy_Name --
439 -------------------------------------
441 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
443 return N in First_Task_Dispatching_Policy_Name ..
444 Last_Task_Dispatching_Policy_Name;
445 end Is_Task_Dispatching_Policy_Name;
447 ----------------------------
448 -- Is_Type_Attribute_Name --
449 ----------------------------
451 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
453 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
454 end Is_Type_Attribute_Name;
456 ----------------------------------
457 -- Record_Convention_Identifier --
458 ----------------------------------
460 procedure Record_Convention_Identifier
462 Convention : Convention_Id)
465 Convention_Identifiers.Append ((Id, Convention));
466 end Record_Convention_Identifier;