gcc/ada/snames.adb-tmpl

   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-2016, 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 ------------------------------------------------------------------------------
  31
  32 with Debug; use Debug;
  33 with Opt;   use Opt;
  34 with Table;
  35 with Types; use Types;
  36
  37 package body Snames is
  38
  39    --  Table used to record convention identifiers
  40
  41    type Convention_Id_Entry is record
  42       Name       : Name_Id;
  43       Convention : Convention_Id;
  44    end record;
  45
  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");
  53
  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.
  58
  59    Preset_Names : constant String :=
  60 !! TEMPLATE INSERTION POINT
  61      "#";
  62
  63    ---------------------
  64    -- Generated Names --
  65    ---------------------
  66
  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).
  75
  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)
  99
 100    --  TSS names
 101
 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)
 118
 119    --  Implicit type names
 120
 121    --    TxxxT   type of literal table for enumeration type xxx     (Sem_Ch3)
 122
 123    --  (Note: this list is not complete or accurate ???)
 124
 125    ----------------------
 126    -- Get_Attribute_Id --
 127    ----------------------
 128
 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;
 141
 142    -----------------------
 143    -- Get_Convention_Id --
 144    -----------------------
 145
 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_COBOL                 => return Convention_COBOL;
 156          when Name_CPP                   => return Convention_CPP;
 157          when Name_Fortran               => return Convention_Fortran;
 158          when Name_Intrinsic             => return Convention_Intrinsic;
 159          when Name_Stdcall               => return Convention_Stdcall;
 160          when Name_Stubbed               => return Convention_Stubbed;
 161
 162          --  If no direct match, then we must have a convention
 163          --  identifier pragma that has specified this name.
 164
 165          when others                     =>
 166             for J in 1 .. Convention_Identifiers.Last loop
 167                if N = Convention_Identifiers.Table (J).Name then
 168                   return Convention_Identifiers.Table (J).Convention;
 169                end if;
 170             end loop;
 171
 172             raise Program_Error;
 173       end case;
 174    end Get_Convention_Id;
 175
 176    -------------------------
 177    -- Get_Convention_Name --
 178    -------------------------
 179
 180    function Get_Convention_Name (C : Convention_Id) return Name_Id is
 181    begin
 182       case C is
 183          when Convention_Ada                   => return Name_Ada;
 184          when Convention_Ada_Pass_By_Copy      => return Name_Ada_Pass_By_Copy;
 185          when Convention_Ada_Pass_By_Reference =>
 186             return Name_Ada_Pass_By_Reference;
 187          when Convention_Assembler             => return Name_Assembler;
 188          when Convention_C                     => return Name_C;
 189          when Convention_COBOL                 => return Name_COBOL;
 190          when Convention_CPP                   => return Name_CPP;
 191          when Convention_Entry                 => return Name_Entry;
 192          when Convention_Fortran               => return Name_Fortran;
 193          when Convention_Intrinsic             => return Name_Intrinsic;
 194          when Convention_Protected             => return Name_Protected;
 195          when Convention_Stdcall               => return Name_Stdcall;
 196          when Convention_Stubbed               => return Name_Stubbed;
 197       end case;
 198    end Get_Convention_Name;
 199
 200    ---------------------------
 201    -- Get_Locking_Policy_Id --
 202    ---------------------------
 203
 204    function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
 205    begin
 206       return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
 207    end Get_Locking_Policy_Id;
 208
 209    -------------------
 210    -- Get_Pragma_Id --
 211    -------------------
 212
 213    function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
 214    begin
 215       case N is
 216          when Name_CPU                              =>
 217             return Pragma_CPU;
 218          when Name_Default_Scalar_Storage_Order     =>
 219             return Pragma_Default_Scalar_Storage_Order;
 220          when Name_Dispatching_Domain               =>
 221             return Pragma_Dispatching_Domain;
 222          when Name_Fast_Math                        =>
 223             return Pragma_Fast_Math;
 224          when Name_Interface                        =>
 225             return Pragma_Interface;
 226          when Name_Interrupt_Priority               =>
 227             return Pragma_Interrupt_Priority;
 228          when Name_Lock_Free                        =>
 229             return Pragma_Lock_Free;
 230          when Name_Priority                         =>
 231             return Pragma_Priority;
 232          when Name_Secondary_Stack_Size             =>
 233             return Pragma_Secondary_Stack_Size;
 234          when Name_Storage_Size                     =>
 235             return Pragma_Storage_Size;
 236          when Name_Storage_Unit                     =>
 237             return Pragma_Storage_Unit;
 238          when First_Pragma_Name .. Last_Pragma_Name =>
 239             return Pragma_Id'Val (N - First_Pragma_Name);
 240          when others                                =>
 241             return Unknown_Pragma;
 242       end case;
 243    end Get_Pragma_Id;
 244
 245    ---------------------------
 246    -- Get_Queuing_Policy_Id --
 247    ---------------------------
 248
 249    function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
 250    begin
 251       return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
 252    end Get_Queuing_Policy_Id;
 253
 254    ------------------------------------
 255    -- Get_Task_Dispatching_Policy_Id --
 256    ------------------------------------
 257
 258    function Get_Task_Dispatching_Policy_Id
 259      (N : Name_Id) return Task_Dispatching_Policy_Id
 260    is
 261    begin
 262       return Task_Dispatching_Policy_Id'Val
 263         (N - First_Task_Dispatching_Policy_Name);
 264    end Get_Task_Dispatching_Policy_Id;
 265
 266    ----------------
 267    -- Initialize --
 268    ----------------
 269
 270    procedure Initialize is
 271       P_Index      : Natural;
 272       Discard_Name : Name_Id;
 273
 274    begin
 275       P_Index := Preset_Names'First;
 276       loop
 277          Name_Len := 0;
 278          while Preset_Names (P_Index) /= '#' loop
 279             Name_Len := Name_Len + 1;
 280             Name_Buffer (Name_Len) := Preset_Names (P_Index);
 281             P_Index := P_Index + 1;
 282          end loop;
 283
 284          --  We do the Name_Find call to enter the name into the table, but
 285          --  we don't need to do anything with the result, since we already
 286          --  initialized all the preset names to have the right value (we
 287          --  are depending on the order of the names and Preset_Names).
 288
 289          Discard_Name := Name_Find;
 290          P_Index := P_Index + 1;
 291          exit when Preset_Names (P_Index) = '#';
 292       end loop;
 293
 294       --  Make sure that number of names in standard table is correct. If this
 295       --  check fails, run utility program XSNAMES to construct a new properly
 296       --  matching version of the body.
 297
 298       pragma Assert (Discard_Name = Last_Predefined_Name);
 299
 300       --  Initialize the convention identifiers table with the standard set of
 301       --  synonyms that we recognize for conventions.
 302
 303       Convention_Identifiers.Init;
 304
 305       Convention_Identifiers.Append ((Name_Asm,         Convention_Assembler));
 306       Convention_Identifiers.Append ((Name_Assembly,    Convention_Assembler));
 307
 308       Convention_Identifiers.Append ((Name_Default,     Convention_C));
 309       Convention_Identifiers.Append ((Name_External,    Convention_C));
 310
 311       Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
 312
 313       Convention_Identifiers.Append ((Name_DLL,         Convention_Stdcall));
 314       Convention_Identifiers.Append ((Name_Win32,       Convention_Stdcall));
 315    end Initialize;
 316
 317    -----------------------
 318    -- Is_Attribute_Name --
 319    -----------------------
 320
 321    function Is_Attribute_Name (N : Name_Id) return Boolean is
 322    begin
 323       --  Don't consider Name_Elab_Subp_Body to be a valid attribute name
 324       --  unless we are working in CodePeer mode.
 325
 326       return N in First_Attribute_Name .. Last_Attribute_Name
 327         and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body);
 328    end Is_Attribute_Name;
 329
 330    ----------------------------------
 331    -- Is_Configuration_Pragma_Name --
 332    ----------------------------------
 333
 334    function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
 335    begin
 336       return N in Configuration_Pragma_Names
 337         or else N = Name_Default_Scalar_Storage_Order
 338         or else N = Name_Fast_Math;
 339    end Is_Configuration_Pragma_Name;
 340
 341    ------------------------
 342    -- Is_Convention_Name --
 343    ------------------------
 344
 345    function Is_Convention_Name (N : Name_Id) return Boolean is
 346    begin
 347       --  Check if this is one of the standard conventions
 348
 349       if N in First_Convention_Name .. Last_Convention_Name
 350         or else N = Name_C
 351       then
 352          return True;
 353
 354       --  Otherwise check if it is in convention identifier table
 355
 356       else
 357          for J in 1 .. Convention_Identifiers.Last loop
 358             if N = Convention_Identifiers.Table (J).Name then
 359                return True;
 360             end if;
 361          end loop;
 362
 363          return False;
 364       end if;
 365    end Is_Convention_Name;
 366
 367    ------------------------------
 368    -- Is_Entity_Attribute_Name --
 369    ------------------------------
 370
 371    function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
 372    begin
 373       return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
 374    end Is_Entity_Attribute_Name;
 375
 376    --------------------------------
 377    -- Is_Function_Attribute_Name --
 378    --------------------------------
 379
 380    function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
 381    begin
 382       return N in
 383         First_Renamable_Function_Attribute ..
 384           Last_Renamable_Function_Attribute;
 385    end Is_Function_Attribute_Name;
 386
 387    ---------------------
 388    -- Is_Keyword_Name --
 389    ---------------------
 390
 391    function Is_Keyword_Name (N : Name_Id) return Boolean is
 392    begin
 393       return Get_Name_Table_Byte (N) /= 0
 394         and then (Ada_Version >= Ada_95
 395                    or else N not in Ada_95_Reserved_Words)
 396         and then (Ada_Version >= Ada_2005
 397                    or else N not in Ada_2005_Reserved_Words
 398                    or else (Debug_Flag_Dot_DD and then N = Name_Overriding))
 399                    --  Accept 'overriding' keywords if -gnatd.D is used,
 400                    --  for compatibility with Ada 95 compilers implementing
 401                    --  only this Ada 2005 extension.
 402         and then (Ada_Version >= Ada_2012
 403                    or else N not in Ada_2012_Reserved_Words);
 404    end Is_Keyword_Name;
 405
 406    --------------------------------
 407    -- Is_Internal_Attribute_Name --
 408    --------------------------------
 409
 410    function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
 411    begin
 412       return
 413         N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
 414    end Is_Internal_Attribute_Name;
 415
 416    ----------------------------
 417    -- Is_Locking_Policy_Name --
 418    ----------------------------
 419
 420    function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
 421    begin
 422       return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
 423    end Is_Locking_Policy_Name;
 424
 425    -------------------------------------
 426    -- Is_Partition_Elaboration_Policy --
 427    -------------------------------------
 428
 429    function Is_Partition_Elaboration_Policy_Name
 430      (N : Name_Id) return Boolean
 431    is
 432    begin
 433       return N in First_Partition_Elaboration_Policy_Name ..
 434                   Last_Partition_Elaboration_Policy_Name;
 435    end Is_Partition_Elaboration_Policy_Name;
 436
 437    -----------------------------
 438    -- Is_Operator_Symbol_Name --
 439    -----------------------------
 440
 441    function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
 442    begin
 443       return N in First_Operator_Name .. Last_Operator_Name;
 444    end Is_Operator_Symbol_Name;
 445
 446    --------------------
 447    -- Is_Pragma_Name --
 448    --------------------
 449
 450    function Is_Pragma_Name (N : Name_Id) return Boolean is
 451    begin
 452       return N in First_Pragma_Name .. Last_Pragma_Name
 453         or else N = Name_CPU
 454         or else N = Name_Default_Scalar_Storage_Order
 455         or else N = Name_Dispatching_Domain
 456         or else N = Name_Fast_Math
 457         or else N = Name_Interface
 458         or else N = Name_Interrupt_Priority
 459         or else N = Name_Lock_Free
 460         or else N = Name_Priority
 461         or else N = Name_Secondary_Stack_Size
 462         or else N = Name_Storage_Size
 463         or else N = Name_Storage_Unit;
 464    end Is_Pragma_Name;
 465
 466    ---------------------------------
 467    -- Is_Procedure_Attribute_Name --
 468    ---------------------------------
 469
 470    function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
 471    begin
 472       return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
 473    end Is_Procedure_Attribute_Name;
 474
 475    ----------------------------
 476    -- Is_Queuing_Policy_Name --
 477    ----------------------------
 478
 479    function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
 480    begin
 481       return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
 482    end Is_Queuing_Policy_Name;
 483
 484    -------------------------------------
 485    -- Is_Task_Dispatching_Policy_Name --
 486    -------------------------------------
 487
 488    function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
 489    begin
 490       return N in First_Task_Dispatching_Policy_Name ..
 491                   Last_Task_Dispatching_Policy_Name;
 492    end Is_Task_Dispatching_Policy_Name;
 493
 494    ----------------------------
 495    -- Is_Type_Attribute_Name --
 496    ----------------------------
 497
 498    function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
 499    begin
 500       return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
 501    end Is_Type_Attribute_Name;
 502
 503    ----------------------------------
 504    -- Record_Convention_Identifier --
 505    ----------------------------------
 506
 507    procedure Record_Convention_Identifier
 508      (Id         : Name_Id;
 509       Convention : Convention_Id)
 510    is
 511    begin
 512       Convention_Identifiers.Append ((Id, Convention));
 513    end Record_Convention_Identifier;
 514
 515 end Snames;