2015-05-12 Robert Dewar <dewar@adacore.com>
[official-gcc.git] / gcc / ada / snames.adb-tmpl
blob6e1acd9c22a0522f422efdadb80f29929268b9f9
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-2012, 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 Debug; use Debug;
33 with Opt;   use Opt;
34 with Table;
35 with Types; use Types;
37 package body Snames is
39    --  Table used to record convention identifiers
41    type Convention_Id_Entry is record
42       Name       : Name_Id;
43       Convention : Convention_Id;
44    end record;
46    package Convention_Identifiers is new Table.Table (
47      Table_Component_Type => Convention_Id_Entry,
48      Table_Index_Type     => Int,
49      Table_Low_Bound      => 1,
50      Table_Initial        => 50,
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
61      "#";
63    ---------------------
64    -- Generated Names --
65    ---------------------
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)
100    --  TSS names
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
130    begin
131       if N = Name_CPU then
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;
137       else
138          return Attribute_Id'Val (N - First_Attribute_Name);
139       end if;
140    end Get_Attribute_Id;
142    -----------------------
143    -- Get_Convention_Id --
144    -----------------------
146    function Get_Convention_Id (N : Name_Id) return Convention_Id is
147    begin
148       case N 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.
167          when others                     =>
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;
171                end if;
172             end loop;
174             raise Program_Error;
175       end case;
176    end Get_Convention_Id;
178    -------------------------
179    -- Get_Convention_Name --
180    -------------------------
182    function Get_Convention_Name (C : Convention_Id) return Name_Id is
183    begin
184       case C 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;
201       end case;
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
209    begin
210       return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
211    end Get_Locking_Policy_Id;
213    -------------------
214    -- Get_Pragma_Id --
215    -------------------
217    function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
218    begin
219       case N is
220          when Name_CPU                              =>
221             return Pragma_CPU;
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);
242          when others                                =>
243             return Unknown_Pragma;
244       end case;
245    end Get_Pragma_Id;
247    ---------------------------
248    -- Get_Queuing_Policy_Id --
249    ---------------------------
251    function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
252    begin
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
262    is
263    begin
264       return Task_Dispatching_Policy_Id'Val
265         (N - First_Task_Dispatching_Policy_Name);
266    end Get_Task_Dispatching_Policy_Id;
268    ----------------
269    -- Initialize --
270    ----------------
272    procedure Initialize is
273       P_Index      : Natural;
274       Discard_Name : Name_Id;
276    begin
277       P_Index := Preset_Names'First;
278       loop
279          Name_Len := 0;
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;
284          end loop;
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) = '#';
294       end loop;
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));
317    end Initialize;
319    -----------------------
320    -- Is_Attribute_Name --
321    -----------------------
323    function Is_Attribute_Name (N : Name_Id) return Boolean is
324    begin
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
337    begin
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
348    begin
349       --  Check if this is one of the standard conventions
351       if N in First_Convention_Name .. Last_Convention_Name
352         or else N = Name_C
353       then
354          return True;
356       --  Otherwise check if it is in convention identifier table
358       else
359          for J in 1 .. Convention_Identifiers.Last loop
360             if N = Convention_Identifiers.Table (J).Name then
361                return True;
362             end if;
363          end loop;
365          return False;
366       end if;
367    end Is_Convention_Name;
369    ------------------------------
370    -- Is_Entity_Attribute_Name --
371    ------------------------------
373    function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
374    begin
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
383    begin
384       return N in
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
394    begin
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);
406    end Is_Keyword_Name;
408    --------------------------------
409    -- Is_Internal_Attribute_Name --
410    --------------------------------
412    function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
413    begin
414       return
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
423    begin
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
433    is
434    begin
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
444    begin
445       return N in First_Operator_Name .. Last_Operator_Name;
446    end Is_Operator_Symbol_Name;
448    --------------------
449    -- Is_Pragma_Name --
450    --------------------
452    function Is_Pragma_Name (N : Name_Id) return Boolean is
453    begin
454       return N in First_Pragma_Name .. Last_Pragma_Name
455         or else N = Name_CPU
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;
466    end Is_Pragma_Name;
468    ---------------------------------
469    -- Is_Procedure_Attribute_Name --
470    ---------------------------------
472    function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
473    begin
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
482    begin
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
491    begin
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
501    begin
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
510      (Id         : Name_Id;
511       Convention : Convention_Id)
512    is
513    begin
514       Convention_Identifiers.Append ((Id, Convention));
515    end Record_Convention_Identifier;
517 end Snames;