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