summaryrefslogtreecommitdiff
path: root/gcc/ada/snames.adb-tmpl
blob: 164b11d35480095035944ddd58048b456e21134f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               S N A M E S                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Opt;   use Opt;
with Table;
with Types; use Types;

package body Snames is

   --  Table used to record convention identifiers

   type Convention_Id_Entry is record
      Name       : Name_Id;
      Convention : Convention_Id;
   end record;

   package Convention_Identifiers is new Table.Table (
     Table_Component_Type => Convention_Id_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 1,
     Table_Initial        => 50,
     Table_Increment      => 200,
     Table_Name           => "Name_Convention_Identifiers");

   --  Table of names to be set by Initialize. Each name is terminated by a
   --  single #, and the end of the list is marked by a null entry, i.e. by
   --  two # marks in succession. Note that the table does not include the
   --  entries for a-z, since these are initialized by Namet itself.

   Preset_Names : constant String :=
!! TEMPLATE INSERTION POINT
     "#";

   ---------------------
   -- Generated Names --
   ---------------------

   --  This section lists the various cases of generated names which are
   --  built from existing names by adding unique leading and/or trailing
   --  upper case letters. In some cases these names are built recursively,
   --  in particular names built from types may be built from types which
   --  themselves have generated names. In this list, xxx represents an
   --  existing name to which identifying letters are prepended or appended,
   --  and a trailing n represents a serial number in an external name that
   --  has some semantic significance (e.g. the n'th index type of an array).

   --    xxxA    access type for formal xxx in entry param record   (Exp_Ch9)
   --    xxxB    tag table for tagged type xxx                      (Exp_Ch3)
   --    xxxB    task body procedure for task xxx                   (Exp_Ch9)
   --    xxxD    dispatch table for tagged type xxx                 (Exp_Ch3)
   --    xxxD    discriminal for discriminant xxx                   (Sem_Ch3)
   --    xxxDn   n'th discr check function for rec type xxx         (Exp_Ch3)
   --    xxxE    elaboration boolean flag for task xxx              (Exp_Ch9)
   --    xxxE    dispatch table pointer type for tagged type xxx    (Exp_Ch3)
   --    xxxE    parameters for accept body for entry xxx           (Exp_Ch9)
   --    xxxFn   n'th primitive of a tagged type (named xxx)        (Exp_Ch3)
   --    xxxJ    tag table type index for tagged type xxx           (Exp_Ch3)
   --    xxxM    master Id value for access type xxx                (Exp_Ch3)
   --    xxxP    tag table pointer type for tagged type xxx         (Exp_Ch3)
   --    xxxP    parameter record type for entry xxx                (Exp_Ch9)
   --    xxxPA   access to parameter record type for entry xxx      (Exp_Ch9)
   --    xxxPn   pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
   --    xxxR    dispatch table pointer for tagged type xxx         (Exp_Ch3)
   --    xxxT    tag table type for tagged type xxx                 (Exp_Ch3)
   --    xxxT    literal table for enumeration type xxx             (Sem_Ch3)
   --    xxxV    type for task value record for task xxx            (Exp_Ch9)
   --    xxxX    entry index constant                               (Exp_Ch9)
   --    xxxY    dispatch table type for tagged type xxx            (Exp_Ch3)
   --    xxxZ    size variable for task xxx                         (Exp_Ch9)

   --  TSS names

   --    xxxDA   deep adjust routine for type xxx                   (Exp_TSS)
   --    xxxDF   deep finalize routine for type xxx                 (Exp_TSS)
   --    xxxDI   deep initialize routine for type xxx               (Exp_TSS)
   --    xxxEQ   composite equality routine for record type xxx     (Exp_TSS)
   --    xxxFA   PolyORB/DSA From_Any converter for type xxx        (Exp_TSS)
   --    xxxIP   initialization procedure for type xxx              (Exp_TSS)
   --    xxxRA   RAS type access routine for type xxx               (Exp_TSS)
   --    xxxRD   RAS type dereference routine for type xxx          (Exp_TSS)
   --    xxxRP   Rep to Pos conversion for enumeration type xxx     (Exp_TSS)
   --    xxxSA   array/slice assignment for controlled comp. arrays (Exp_TSS)
   --    xxxSI   stream input attribute subprogram for type xxx     (Exp_TSS)
   --    xxxSO   stream output attribute subprogram for type xxx    (Exp_TSS)
   --    xxxSR   stream read attribute subprogram for type xxx      (Exp_TSS)
   --    xxxSW   stream write attribute subprogram for type xxx     (Exp_TSS)
   --    xxxTA   PolyORB/DSA To_Any converter for type xxx          (Exp_TSS)
   --    xxxTC   PolyORB/DSA Typecode for type xxx                  (Exp_TSS)

   --  Implicit type names

   --    TxxxT   type of literal table for enumeration type xxx     (Sem_Ch3)

   --  (Note: this list is not complete or accurate ???)

   ----------------------
   -- Get_Attribute_Id --
   ----------------------

   function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
   begin
      return Attribute_Id'Val (N - First_Attribute_Name);
   end Get_Attribute_Id;

   -----------------------
   -- Get_Convention_Id --
   -----------------------

   function Get_Convention_Id (N : Name_Id) return Convention_Id is
   begin
      case N is
         when Name_Ada        => return Convention_Ada;
         when Name_Assembler  => return Convention_Assembler;
         when Name_C          => return Convention_C;
         when Name_CIL        => return Convention_CIL;
         when Name_COBOL      => return Convention_COBOL;
         when Name_CPP        => return Convention_CPP;
         when Name_Fortran    => return Convention_Fortran;
         when Name_Intrinsic  => return Convention_Intrinsic;
         when Name_Java       => return Convention_Java;
         when Name_Stdcall    => return Convention_Stdcall;
         when Name_Stubbed    => return Convention_Stubbed;

         --  If no direct match, then we must have a convention
         --  identifier pragma that has specified this name.

         when others          =>
            for J in 1 .. Convention_Identifiers.Last loop
               if N = Convention_Identifiers.Table (J).Name then
                  return Convention_Identifiers.Table (J).Convention;
               end if;
            end loop;

            raise Program_Error;
      end case;
   end Get_Convention_Id;

   -------------------------
   -- Get_Convention_Name --
   -------------------------

   function Get_Convention_Name (C : Convention_Id) return Name_Id is
   begin
      case C is
         when Convention_Ada       => return Name_Ada;
         when Convention_Assembler => return Name_Assembler;
         when Convention_C         => return Name_C;
         when Convention_CIL       => return Name_CIL;
         when Convention_COBOL     => return Name_COBOL;
         when Convention_CPP       => return Name_CPP;
         when Convention_Entry     => return Name_Entry;
         when Convention_Fortran   => return Name_Fortran;
         when Convention_Intrinsic => return Name_Intrinsic;
         when Convention_Java      => return Name_Java;
         when Convention_Protected => return Name_Protected;
         when Convention_Stdcall   => return Name_Stdcall;
         when Convention_Stubbed   => return Name_Stubbed;
      end case;
   end Get_Convention_Name;

   ---------------------------
   -- Get_Locking_Policy_Id --
   ---------------------------

   function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
   begin
      return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
   end Get_Locking_Policy_Id;

   -------------------
   -- Get_Pragma_Id --
   -------------------

   function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
   begin
      if N = Name_AST_Entry then
         return Pragma_AST_Entry;
      elsif N = Name_Fast_Math then
         return Pragma_Fast_Math;
      elsif N = Name_Interface then
         return Pragma_Interface;
      elsif N = Name_Priority then
         return Pragma_Priority;
      elsif N = Name_Relative_Deadline then
         return Pragma_Relative_Deadline;
      elsif N = Name_Storage_Size then
         return Pragma_Storage_Size;
      elsif N = Name_Storage_Unit then
         return Pragma_Storage_Unit;
      elsif N not in First_Pragma_Name .. Last_Pragma_Name then
         return Unknown_Pragma;
      else
         return Pragma_Id'Val (N - First_Pragma_Name);
      end if;
   end Get_Pragma_Id;

   ---------------------------
   -- Get_Queuing_Policy_Id --
   ---------------------------

   function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
   begin
      return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
   end Get_Queuing_Policy_Id;

   ------------------------------------
   -- Get_Task_Dispatching_Policy_Id --
   ------------------------------------

   function Get_Task_Dispatching_Policy_Id
     (N : Name_Id) return Task_Dispatching_Policy_Id
   is
   begin
      return Task_Dispatching_Policy_Id'Val
        (N - First_Task_Dispatching_Policy_Name);
   end Get_Task_Dispatching_Policy_Id;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      P_Index      : Natural;
      Discard_Name : Name_Id;

   begin
      P_Index := Preset_Names'First;
      loop
         Name_Len := 0;
         while Preset_Names (P_Index) /= '#' loop
            Name_Len := Name_Len + 1;
            Name_Buffer (Name_Len) := Preset_Names (P_Index);
            P_Index := P_Index + 1;
         end loop;

         --  We do the Name_Find call to enter the name into the table, but
         --  we don't need to do anything with the result, since we already
         --  initialized all the preset names to have the right value (we
         --  are depending on the order of the names and Preset_Names).

         Discard_Name := Name_Find;
         P_Index := P_Index + 1;
         exit when Preset_Names (P_Index) = '#';
      end loop;

      --  Make sure that number of names in standard table is correct. If
      --  this check fails, run utility program XSNAMES to construct a new
      --  properly matching version of the body.

      pragma Assert (Discard_Name = Last_Predefined_Name);

      --  Initialize the convention identifiers table with the standard
      --  set of synonyms that we recognize for conventions.

      Convention_Identifiers.Init;

      Convention_Identifiers.Append ((Name_Asm,         Convention_Assembler));
      Convention_Identifiers.Append ((Name_Assembly,    Convention_Assembler));

      Convention_Identifiers.Append ((Name_Default,     Convention_C));
      Convention_Identifiers.Append ((Name_External,    Convention_C));

      Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));

      Convention_Identifiers.Append ((Name_DLL,         Convention_Stdcall));
      Convention_Identifiers.Append ((Name_Win32,       Convention_Stdcall));
   end Initialize;

   -----------------------
   -- Is_Attribute_Name --
   -----------------------

   function Is_Attribute_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Attribute_Name .. Last_Attribute_Name;
   end Is_Attribute_Name;

   ----------------------------------
   -- Is_Configuration_Pragma_Name --
   ----------------------------------

   function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
        or else N = Name_Fast_Math;
   end Is_Configuration_Pragma_Name;

   ------------------------
   -- Is_Convention_Name --
   ------------------------

   function Is_Convention_Name (N : Name_Id) return Boolean is
   begin
      --  Check if this is one of the standard conventions

      if N in First_Convention_Name .. Last_Convention_Name
        or else N = Name_C
      then
         return True;

      --  Otherwise check if it is in convention identifier table

      else
         for J in 1 .. Convention_Identifiers.Last loop
            if N = Convention_Identifiers.Table (J).Name then
               return True;
            end if;
         end loop;

         return False;
      end if;
   end Is_Convention_Name;

   ------------------------------
   -- Is_Entity_Attribute_Name --
   ------------------------------

   function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
   end Is_Entity_Attribute_Name;

   --------------------------------
   -- Is_Function_Attribute_Name --
   --------------------------------

   function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
   begin
      return N in
        First_Renamable_Function_Attribute ..
          Last_Renamable_Function_Attribute;
   end Is_Function_Attribute_Name;

   ---------------------
   -- Is_Keyword_Name --
   ---------------------

   function Is_Keyword_Name (N : Name_Id) return Boolean is
   begin
      return Get_Name_Table_Byte (N) /= 0
        and then (Ada_Version >= Ada_95
                  or else N not in Ada_95_Reserved_Words)
        and then (Ada_Version >= Ada_2005
                  or else N not in Ada_2005_Reserved_Words);
   end Is_Keyword_Name;

   ----------------------------
   -- Is_Locking_Policy_Name --
   ----------------------------

   function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
   end Is_Locking_Policy_Name;

   -----------------------------
   -- Is_Operator_Symbol_Name --
   -----------------------------

   function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Operator_Name .. Last_Operator_Name;
   end Is_Operator_Symbol_Name;

   --------------------
   -- Is_Pragma_Name --
   --------------------

   function Is_Pragma_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Pragma_Name .. Last_Pragma_Name
        or else N = Name_AST_Entry
        or else N = Name_Fast_Math
        or else N = Name_Interface
        or else N = Name_Relative_Deadline
        or else N = Name_Priority
        or else N = Name_Storage_Size
        or else N = Name_Storage_Unit;
   end Is_Pragma_Name;

   ---------------------------------
   -- Is_Procedure_Attribute_Name --
   ---------------------------------

   function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
   end Is_Procedure_Attribute_Name;

   ----------------------------
   -- Is_Queuing_Policy_Name --
   ----------------------------

   function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
   end Is_Queuing_Policy_Name;

   -------------------------------------
   -- Is_Task_Dispatching_Policy_Name --
   -------------------------------------

   function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Task_Dispatching_Policy_Name ..
                  Last_Task_Dispatching_Policy_Name;
   end Is_Task_Dispatching_Policy_Name;

   ----------------------------
   -- Is_Type_Attribute_Name --
   ----------------------------

   function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
   begin
      return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
   end Is_Type_Attribute_Name;

   ----------------------------------
   -- Record_Convention_Identifier --
   ----------------------------------

   procedure Record_Convention_Identifier
     (Id         : Name_Id;
      Convention : Convention_Id)
   is
   begin
      Convention_Identifiers.Append ((Id, Convention));
   end Record_Convention_Identifier;

end Snames;