fixing pr42337
[official-gcc.git] / gcc / ada / snames.adb-tmpl
blobd3e6d353b6d8bca3e07129494f518db6f823a023
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-2009, 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.                                     --
17 --                                                                          --
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.               --
21 --                                                                          --
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/>.                                          --
26 --                                                                          --
27 -- GNAT was originally developed  by the GNAT team at  New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
29 --                                                                          --
30 ------------------------------------------------------------------------------
32 with Opt;   use Opt;
33 with Table;
34 with Types; use Types;
36 package body Snames is
38    --  Table used to record convention identifiers
40    type Convention_Id_Entry is record
41       Name       : Name_Id;
42       Convention : Convention_Id;
43    end record;
45    package Convention_Identifiers is new Table.Table (
46      Table_Component_Type => Convention_Id_Entry,
47      Table_Index_Type     => Int,
48      Table_Low_Bound      => 1,
49      Table_Initial        => 50,
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
60      "#";
62    ---------------------
63    -- Generated Names --
64    ---------------------
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)
99    --  TSS names
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
129    begin
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
138    begin
139       case N is
140          when Name_Ada        => return Convention_Ada;
141          when Name_Assembler  => return Convention_Assembler;
142          when Name_C          => return Convention_C;
143          when Name_CIL        => return Convention_CIL;
144          when Name_COBOL      => return Convention_COBOL;
145          when Name_CPP        => return Convention_CPP;
146          when Name_Fortran    => return Convention_Fortran;
147          when Name_Intrinsic  => return Convention_Intrinsic;
148          when Name_Java       => return Convention_Java;
149          when Name_Stdcall    => return Convention_Stdcall;
150          when Name_Stubbed    => return Convention_Stubbed;
152          --  If no direct match, then we must have a convention
153          --  identifier pragma that has specified this name.
155          when others          =>
156             for J in 1 .. Convention_Identifiers.Last loop
157                if N = Convention_Identifiers.Table (J).Name then
158                   return Convention_Identifiers.Table (J).Convention;
159                end if;
160             end loop;
162             raise Program_Error;
163       end case;
164    end Get_Convention_Id;
166    -------------------------
167    -- Get_Convention_Name --
168    -------------------------
170    function Get_Convention_Name (C : Convention_Id) return Name_Id is
171    begin
172       case C is
173          when Convention_Ada       => return Name_Ada;
174          when Convention_Assembler => return Name_Assembler;
175          when Convention_C         => return Name_C;
176          when Convention_CIL       => return Name_CIL;
177          when Convention_COBOL     => return Name_COBOL;
178          when Convention_CPP       => return Name_CPP;
179          when Convention_Entry     => return Name_Entry;
180          when Convention_Fortran   => return Name_Fortran;
181          when Convention_Intrinsic => return Name_Intrinsic;
182          when Convention_Java      => return Name_Java;
183          when Convention_Protected => return Name_Protected;
184          when Convention_Stdcall   => return Name_Stdcall;
185          when Convention_Stubbed   => return Name_Stubbed;
186       end case;
187    end Get_Convention_Name;
189    ---------------------------
190    -- Get_Locking_Policy_Id --
191    ---------------------------
193    function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
194    begin
195       return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
196    end Get_Locking_Policy_Id;
198    -------------------
199    -- Get_Pragma_Id --
200    -------------------
202    function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
203    begin
204       if N = Name_AST_Entry then
205          return Pragma_AST_Entry;
206       elsif N = Name_Fast_Math then
207          return Pragma_Fast_Math;
208       elsif N = Name_Interface then
209          return Pragma_Interface;
210       elsif N = Name_Priority then
211          return Pragma_Priority;
212       elsif N = Name_Relative_Deadline then
213          return Pragma_Relative_Deadline;
214       elsif N = Name_Storage_Size then
215          return Pragma_Storage_Size;
216       elsif N = Name_Storage_Unit then
217          return Pragma_Storage_Unit;
218       elsif N not in First_Pragma_Name .. Last_Pragma_Name then
219          return Unknown_Pragma;
220       else
221          return Pragma_Id'Val (N - First_Pragma_Name);
222       end if;
223    end Get_Pragma_Id;
225    ---------------------------
226    -- Get_Queuing_Policy_Id --
227    ---------------------------
229    function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
230    begin
231       return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
232    end Get_Queuing_Policy_Id;
234    ------------------------------------
235    -- Get_Task_Dispatching_Policy_Id --
236    ------------------------------------
238    function Get_Task_Dispatching_Policy_Id
239      (N : Name_Id) return Task_Dispatching_Policy_Id
240    is
241    begin
242       return Task_Dispatching_Policy_Id'Val
243         (N - First_Task_Dispatching_Policy_Name);
244    end Get_Task_Dispatching_Policy_Id;
246    ----------------
247    -- Initialize --
248    ----------------
250    procedure Initialize is
251       P_Index      : Natural;
252       Discard_Name : Name_Id;
254    begin
255       P_Index := Preset_Names'First;
256       loop
257          Name_Len := 0;
258          while Preset_Names (P_Index) /= '#' loop
259             Name_Len := Name_Len + 1;
260             Name_Buffer (Name_Len) := Preset_Names (P_Index);
261             P_Index := P_Index + 1;
262          end loop;
264          --  We do the Name_Find call to enter the name into the table, but
265          --  we don't need to do anything with the result, since we already
266          --  initialized all the preset names to have the right value (we
267          --  are depending on the order of the names and Preset_Names).
269          Discard_Name := Name_Find;
270          P_Index := P_Index + 1;
271          exit when Preset_Names (P_Index) = '#';
272       end loop;
274       --  Make sure that number of names in standard table is correct. If
275       --  this check fails, run utility program XSNAMES to construct a new
276       --  properly matching version of the body.
278       pragma Assert (Discard_Name = Last_Predefined_Name);
280       --  Initialize the convention identifiers table with the standard
281       --  set of synonyms that we recognize for conventions.
283       Convention_Identifiers.Init;
285       Convention_Identifiers.Append ((Name_Asm,         Convention_Assembler));
286       Convention_Identifiers.Append ((Name_Assembly,    Convention_Assembler));
288       Convention_Identifiers.Append ((Name_Default,     Convention_C));
289       Convention_Identifiers.Append ((Name_External,    Convention_C));
291       Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
293       Convention_Identifiers.Append ((Name_DLL,         Convention_Stdcall));
294       Convention_Identifiers.Append ((Name_Win32,       Convention_Stdcall));
295    end Initialize;
297    -----------------------
298    -- Is_Attribute_Name --
299    -----------------------
301    function Is_Attribute_Name (N : Name_Id) return Boolean is
302    begin
303       return N in First_Attribute_Name .. Last_Attribute_Name;
304    end Is_Attribute_Name;
306    ----------------------------------
307    -- Is_Configuration_Pragma_Name --
308    ----------------------------------
310    function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
311    begin
312       return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
313         or else N = Name_Fast_Math;
314    end Is_Configuration_Pragma_Name;
316    ------------------------
317    -- Is_Convention_Name --
318    ------------------------
320    function Is_Convention_Name (N : Name_Id) return Boolean is
321    begin
322       --  Check if this is one of the standard conventions
324       if N in First_Convention_Name .. Last_Convention_Name
325         or else N = Name_C
326       then
327          return True;
329       --  Otherwise check if it is in convention identifier table
331       else
332          for J in 1 .. Convention_Identifiers.Last loop
333             if N = Convention_Identifiers.Table (J).Name then
334                return True;
335             end if;
336          end loop;
338          return False;
339       end if;
340    end Is_Convention_Name;
342    ------------------------------
343    -- Is_Entity_Attribute_Name --
344    ------------------------------
346    function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
347    begin
348       return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
349    end Is_Entity_Attribute_Name;
351    --------------------------------
352    -- Is_Function_Attribute_Name --
353    --------------------------------
355    function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
356    begin
357       return N in
358         First_Renamable_Function_Attribute ..
359           Last_Renamable_Function_Attribute;
360    end Is_Function_Attribute_Name;
362    ---------------------
363    -- Is_Keyword_Name --
364    ---------------------
366    function Is_Keyword_Name (N : Name_Id) return Boolean is
367    begin
368       return Get_Name_Table_Byte (N) /= 0
369         and then (Ada_Version >= Ada_95
370                   or else N not in Ada_95_Reserved_Words)
371         and then (Ada_Version >= Ada_05
372                   or else N not in Ada_2005_Reserved_Words);
373    end Is_Keyword_Name;
375    ----------------------------
376    -- Is_Locking_Policy_Name --
377    ----------------------------
379    function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
380    begin
381       return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
382    end Is_Locking_Policy_Name;
384    -----------------------------
385    -- Is_Operator_Symbol_Name --
386    -----------------------------
388    function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
389    begin
390       return N in First_Operator_Name .. Last_Operator_Name;
391    end Is_Operator_Symbol_Name;
393    --------------------
394    -- Is_Pragma_Name --
395    --------------------
397    function Is_Pragma_Name (N : Name_Id) return Boolean is
398    begin
399       return N in First_Pragma_Name .. Last_Pragma_Name
400         or else N = Name_AST_Entry
401         or else N = Name_Fast_Math
402         or else N = Name_Interface
403         or else N = Name_Relative_Deadline
404         or else N = Name_Priority
405         or else N = Name_Storage_Size
406         or else N = Name_Storage_Unit;
407    end Is_Pragma_Name;
409    ---------------------------------
410    -- Is_Procedure_Attribute_Name --
411    ---------------------------------
413    function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
414    begin
415       return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
416    end Is_Procedure_Attribute_Name;
418    ----------------------------
419    -- Is_Queuing_Policy_Name --
420    ----------------------------
422    function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
423    begin
424       return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
425    end Is_Queuing_Policy_Name;
427    -------------------------------------
428    -- Is_Task_Dispatching_Policy_Name --
429    -------------------------------------
431    function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
432    begin
433       return N in First_Task_Dispatching_Policy_Name ..
434                   Last_Task_Dispatching_Policy_Name;
435    end Is_Task_Dispatching_Policy_Name;
437    ----------------------------
438    -- Is_Type_Attribute_Name --
439    ----------------------------
441    function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
442    begin
443       return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
444    end Is_Type_Attribute_Name;
446    ----------------------------------
447    -- Record_Convention_Identifier --
448    ----------------------------------
450    procedure Record_Convention_Identifier
451      (Id         : Name_Id;
452       Convention : Convention_Id)
453    is
454    begin
455       Convention_Identifiers.Append ((Id, Convention));
456    end Record_Convention_Identifier;
458 end Snames;