1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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. 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
36 with Types; use Types;
38 package body Snames is
40 -- Table used to record convention identifiers
42 type Convention_Id_Entry is record
44 Convention : Convention_Id;
47 package Convention_Identifiers is new Table.Table (
48 Table_Component_Type => Convention_Id_Entry,
49 Table_Index_Type => Int,
52 Table_Increment => 200,
53 Table_Name => "Name_Convention_Identifiers");
55 -- Table of names to be set by Initialize. Each name is terminated by a
56 -- single #, and the end of the list is marked by a null entry, i.e. by
57 -- two # marks in succession. Note that the table does not include the
58 -- entries for a-z, since these are initialized by Namet itself.
60 Preset_Names : constant String :=
61 !! TEMPLATE INSERTION POINT
68 -- This section lists the various cases of generated names which are
69 -- built from existing names by adding unique leading and/or trailing
70 -- upper case letters. In some cases these names are built recursively,
71 -- in particular names built from types may be built from types which
72 -- themselves have generated names. In this list, xxx represents an
73 -- existing name to which identifying letters are prepended or appended,
74 -- and a trailing n represents a serial number in an external name that
75 -- has some semantic significance (e.g. the n'th index type of an array).
77 -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
78 -- xxxB tag table for tagged type xxx (Exp_Ch3)
79 -- xxxB task body procedure for task xxx (Exp_Ch9)
80 -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
81 -- xxxD discriminal for discriminant xxx (Sem_Ch3)
82 -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
83 -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
84 -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
85 -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
86 -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
87 -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
88 -- xxxM master Id value for access type xxx (Exp_Ch3)
89 -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
90 -- xxxP parameter record type for entry xxx (Exp_Ch9)
91 -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
92 -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
93 -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
94 -- xxxT tag table type for tagged type xxx (Exp_Ch3)
95 -- xxxT literal table for enumeration type xxx (Sem_Ch3)
96 -- xxxV type for task value record for task xxx (Exp_Ch9)
97 -- xxxX entry index constant (Exp_Ch9)
98 -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
99 -- xxxZ size variable for task xxx (Exp_Ch9)
103 -- xxxDA deep adjust routine for type xxx (Exp_TSS)
104 -- xxxDF deep finalize routine for type xxx (Exp_TSS)
105 -- xxxDI deep initialize routine for type xxx (Exp_TSS)
106 -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
107 -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
108 -- xxxIP initialization procedure for type xxx (Exp_TSS)
109 -- xxxRA RAS type access routine for type xxx (Exp_TSS)
110 -- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
111 -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
112 -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
113 -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
114 -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
115 -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
116 -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
117 -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
118 -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
120 -- Implicit type names
122 -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
124 -- (Note: this list is not complete or accurate ???)
126 ----------------------
127 -- Get_Attribute_Id --
128 ----------------------
130 function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
132 return Attribute_Id'Val (N - First_Attribute_Name);
133 end Get_Attribute_Id;
135 -----------------------
136 -- Get_Convention_Id --
137 -----------------------
139 function Get_Convention_Id (N : Name_Id) return Convention_Id is
142 when Name_Ada => return Convention_Ada;
143 when Name_Assembler => return Convention_Assembler;
144 when Name_C => return Convention_C;
145 when Name_CIL => return Convention_CIL;
146 when Name_COBOL => return Convention_COBOL;
147 when Name_CPP => return Convention_CPP;
148 when Name_Fortran => return Convention_Fortran;
149 when Name_Intrinsic => return Convention_Intrinsic;
150 when Name_Java => return Convention_Java;
151 when Name_Stdcall => return Convention_Stdcall;
152 when Name_Stubbed => return Convention_Stubbed;
154 -- If no direct match, then we must have a convention
155 -- identifier pragma that has specified this name.
158 for J in 1 .. Convention_Identifiers.Last loop
159 if N = Convention_Identifiers.Table (J).Name then
160 return Convention_Identifiers.Table (J).Convention;
166 end Get_Convention_Id;
168 -------------------------
169 -- Get_Convention_Name --
170 -------------------------
172 function Get_Convention_Name (C : Convention_Id) return Name_Id is
175 when Convention_Ada => return Name_Ada;
176 when Convention_Assembler => return Name_Assembler;
177 when Convention_C => return Name_C;
178 when Convention_CIL => return Name_CIL;
179 when Convention_COBOL => return Name_COBOL;
180 when Convention_CPP => return Name_CPP;
181 when Convention_Entry => return Name_Entry;
182 when Convention_Fortran => return Name_Fortran;
183 when Convention_Intrinsic => return Name_Intrinsic;
184 when Convention_Java => return Name_Java;
185 when Convention_Protected => return Name_Protected;
186 when Convention_Stdcall => return Name_Stdcall;
187 when Convention_Stubbed => return Name_Stubbed;
189 end Get_Convention_Name;
191 ---------------------------
192 -- Get_Locking_Policy_Id --
193 ---------------------------
195 function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
197 return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
198 end Get_Locking_Policy_Id;
204 function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
206 if N = Name_AST_Entry then
207 return Pragma_AST_Entry;
208 elsif N = Name_Fast_Math then
209 return Pragma_Fast_Math;
210 elsif N = Name_Interface then
211 return Pragma_Interface;
212 elsif N = Name_Priority then
213 return Pragma_Priority;
214 elsif N = Name_Relative_Deadline then
215 return Pragma_Relative_Deadline;
216 elsif N = Name_Storage_Size then
217 return Pragma_Storage_Size;
218 elsif N = Name_Storage_Unit then
219 return Pragma_Storage_Unit;
220 elsif N not in First_Pragma_Name .. Last_Pragma_Name then
221 return Unknown_Pragma;
223 return Pragma_Id'Val (N - First_Pragma_Name);
227 ---------------------------
228 -- Get_Queuing_Policy_Id --
229 ---------------------------
231 function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
233 return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
234 end Get_Queuing_Policy_Id;
236 ------------------------------------
237 -- Get_Task_Dispatching_Policy_Id --
238 ------------------------------------
240 function Get_Task_Dispatching_Policy_Id
241 (N : Name_Id) return Task_Dispatching_Policy_Id
244 return Task_Dispatching_Policy_Id'Val
245 (N - First_Task_Dispatching_Policy_Name);
246 end Get_Task_Dispatching_Policy_Id;
252 procedure Initialize is
254 Discard_Name : Name_Id;
257 P_Index := Preset_Names'First;
260 while Preset_Names (P_Index) /= '#' loop
261 Name_Len := Name_Len + 1;
262 Name_Buffer (Name_Len) := Preset_Names (P_Index);
263 P_Index := P_Index + 1;
266 -- We do the Name_Find call to enter the name into the table, but
267 -- we don't need to do anything with the result, since we already
268 -- initialized all the preset names to have the right value (we
269 -- are depending on the order of the names and Preset_Names).
271 Discard_Name := Name_Find;
272 P_Index := P_Index + 1;
273 exit when Preset_Names (P_Index) = '#';
276 -- Make sure that number of names in standard table is correct. If
277 -- this check fails, run utility program XSNAMES to construct a new
278 -- properly matching version of the body.
280 pragma Assert (Discard_Name = Last_Predefined_Name);
282 -- Initialize the convention identifiers table with the standard
283 -- set of synonyms that we recognize for conventions.
285 Convention_Identifiers.Init;
287 Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
288 Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
290 Convention_Identifiers.Append ((Name_Default, Convention_C));
291 Convention_Identifiers.Append ((Name_External, Convention_C));
293 Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
295 Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
296 Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
299 -----------------------
300 -- Is_Attribute_Name --
301 -----------------------
303 function Is_Attribute_Name (N : Name_Id) return Boolean is
305 return N in First_Attribute_Name .. Last_Attribute_Name;
306 end Is_Attribute_Name;
308 ----------------------------------
309 -- Is_Configuration_Pragma_Name --
310 ----------------------------------
312 function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
314 return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
315 or else N = Name_Fast_Math;
316 end Is_Configuration_Pragma_Name;
318 ------------------------
319 -- Is_Convention_Name --
320 ------------------------
322 function Is_Convention_Name (N : Name_Id) return Boolean is
324 -- Check if this is one of the standard conventions
326 if N in First_Convention_Name .. Last_Convention_Name
331 -- Otherwise check if it is in convention identifier table
334 for J in 1 .. Convention_Identifiers.Last loop
335 if N = Convention_Identifiers.Table (J).Name then
342 end Is_Convention_Name;
344 ------------------------------
345 -- Is_Entity_Attribute_Name --
346 ------------------------------
348 function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
350 return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
351 end Is_Entity_Attribute_Name;
353 --------------------------------
354 -- Is_Function_Attribute_Name --
355 --------------------------------
357 function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
360 First_Renamable_Function_Attribute ..
361 Last_Renamable_Function_Attribute;
362 end Is_Function_Attribute_Name;
364 ---------------------
365 -- Is_Keyword_Name --
366 ---------------------
368 function Is_Keyword_Name (N : Name_Id) return Boolean is
370 return Get_Name_Table_Byte (N) /= 0
371 and then (Ada_Version >= Ada_95
372 or else N not in Ada_95_Reserved_Words)
373 and then (Ada_Version >= Ada_05
374 or else N not in Ada_2005_Reserved_Words);
377 ----------------------------
378 -- Is_Locking_Policy_Name --
379 ----------------------------
381 function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
383 return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
384 end Is_Locking_Policy_Name;
386 -----------------------------
387 -- Is_Operator_Symbol_Name --
388 -----------------------------
390 function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
392 return N in First_Operator_Name .. Last_Operator_Name;
393 end Is_Operator_Symbol_Name;
399 function Is_Pragma_Name (N : Name_Id) return Boolean is
401 return N in First_Pragma_Name .. Last_Pragma_Name
402 or else N = Name_AST_Entry
403 or else N = Name_Fast_Math
404 or else N = Name_Interface
405 or else N = Name_Relative_Deadline
406 or else N = Name_Priority
407 or else N = Name_Storage_Size
408 or else N = Name_Storage_Unit;
411 ---------------------------------
412 -- Is_Procedure_Attribute_Name --
413 ---------------------------------
415 function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
417 return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
418 end Is_Procedure_Attribute_Name;
420 ----------------------------
421 -- Is_Queuing_Policy_Name --
422 ----------------------------
424 function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
426 return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
427 end Is_Queuing_Policy_Name;
429 -------------------------------------
430 -- Is_Task_Dispatching_Policy_Name --
431 -------------------------------------
433 function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
435 return N in First_Task_Dispatching_Policy_Name ..
436 Last_Task_Dispatching_Policy_Name;
437 end Is_Task_Dispatching_Policy_Name;
439 ----------------------------
440 -- Is_Type_Attribute_Name --
441 ----------------------------
443 function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
445 return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
446 end Is_Type_Attribute_Name;
448 ----------------------------------
449 -- Record_Convention_Identifier --
450 ----------------------------------
452 procedure Record_Convention_Identifier
454 Convention : Convention_Id)
457 Convention_Identifiers.Append ((Id, Convention));
458 end Record_Convention_Identifier;