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-2008, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Opt;   use Opt;
  35 with Table;
  36 with Types; use Types;
  37
  38 package body Snames is
  39
  40    --  Table used to record convention identifiers
  41
  42    type Convention_Id_Entry is record
  43       Name       : Name_Id;
  44       Convention : Convention_Id;
  45    end record;
  46
  47    package Convention_Identifiers is new Table.Table (
  48      Table_Component_Type => Convention_Id_Entry,
  49      Table_Index_Type     => Int,
  50      Table_Low_Bound      => 1,
  51      Table_Initial        => 50,
  52      Table_Increment      => 200,
  53      Table_Name           => "Name_Convention_Identifiers");
  54
  55    --  Table of names to be set by Initialize. Each name is terminated by a
  56    --  single #, and the end of the list is marked by a null entry, i.e. by
  57    --  two # marks in succession. Note that the table does not include the
  58    --  entries for a-z, since these are initialized by Namet itself.
  59
  60    Preset_Names : constant String :=
  61 !! TEMPLATE INSERTION POINT
  62      "#";
  63
  64    ---------------------
  65    -- Generated Names --
  66    ---------------------
  67
  68    --  This section lists the various cases of generated names which are
  69    --  built from existing names by adding unique leading and/or trailing
  70    --  upper case letters. In some cases these names are built recursively,
  71    --  in particular names built from types may be built from types which
  72    --  themselves have generated names. In this list, xxx represents an
  73    --  existing name to which identifying letters are prepended or appended,
  74    --  and a trailing n represents a serial number in an external name that
  75    --  has some semantic significance (e.g. the n'th index type of an array).
  76
  77    --    xxxA    access type for formal xxx in entry param record   (Exp_Ch9)
  78    --    xxxB    tag table for tagged type xxx                      (Exp_Ch3)
  79    --    xxxB    task body procedure for task xxx                   (Exp_Ch9)
  80    --    xxxD    dispatch table for tagged type xxx                 (Exp_Ch3)
  81    --    xxxD    discriminal for discriminant xxx                   (Sem_Ch3)
  82    --    xxxDn   n'th discr check function for rec type xxx         (Exp_Ch3)
  83    --    xxxE    elaboration boolean flag for task xxx              (Exp_Ch9)
  84    --    xxxE    dispatch table pointer type for tagged type xxx    (Exp_Ch3)
  85    --    xxxE    parameters for accept body for entry xxx           (Exp_Ch9)
  86    --    xxxFn   n'th primitive of a tagged type (named xxx)        (Exp_Ch3)
  87    --    xxxJ    tag table type index for tagged type xxx           (Exp_Ch3)
  88    --    xxxM    master Id value for access type xxx                (Exp_Ch3)
  89    --    xxxP    tag table pointer type for tagged type xxx         (Exp_Ch3)
  90    --    xxxP    parameter record type for entry xxx                (Exp_Ch9)
  91    --    xxxPA   access to parameter record type for entry xxx      (Exp_Ch9)
  92    --    xxxPn   pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
  93    --    xxxR    dispatch table pointer for tagged type xxx         (Exp_Ch3)
  94    --    xxxT    tag table type for tagged type xxx                 (Exp_Ch3)
  95    --    xxxT    literal table for enumeration type xxx             (Sem_Ch3)
  96    --    xxxV    type for task value record for task xxx            (Exp_Ch9)
  97    --    xxxX    entry index constant                               (Exp_Ch9)
  98    --    xxxY    dispatch table type for tagged type xxx            (Exp_Ch3)
  99    --    xxxZ    size variable for task xxx                         (Exp_Ch9)
 100
 101    --  TSS names
 102
 103    --    xxxDA   deep adjust routine for type xxx                   (Exp_TSS)
 104    --    xxxDF   deep finalize routine for type xxx                 (Exp_TSS)
 105    --    xxxDI   deep initialize routine for type xxx               (Exp_TSS)
 106    --    xxxEQ   composite equality routine for record type xxx     (Exp_TSS)
 107    --    xxxFA   PolyORB/DSA From_Any converter for type xxx        (Exp_TSS)
 108    --    xxxIP   initialization procedure for type xxx              (Exp_TSS)
 109    --    xxxRA   RAS type access routine for type xxx               (Exp_TSS)
 110    --    xxxRD   RAS type dereference routine for type xxx          (Exp_TSS)
 111    --    xxxRP   Rep to Pos conversion for enumeration type xxx     (Exp_TSS)
 112    --    xxxSA   array/slice assignment for controlled comp. arrays (Exp_TSS)
 113    --    xxxSI   stream input attribute subprogram for type xxx     (Exp_TSS)
 114    --    xxxSO   stream output attribute subprogram for type xxx    (Exp_TSS)
 115    --    xxxSR   stream read attribute subprogram for type xxx      (Exp_TSS)
 116    --    xxxSW   stream write attribute subprogram for type xxx     (Exp_TSS)
 117    --    xxxTA   PolyORB/DSA To_Any converter for type xxx          (Exp_TSS)
 118    --    xxxTC   PolyORB/DSA Typecode for type xxx                  (Exp_TSS)
 119
 120    --  Implicit type names
 121
 122    --    TxxxT   type of literal table for enumeration type xxx     (Sem_Ch3)
 123
 124    --  (Note: this list is not complete or accurate ???)
 125
 126    ----------------------
 127    -- Get_Attribute_Id --
 128    ----------------------
 129
 130    function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
 131    begin
 132       return Attribute_Id'Val (N - First_Attribute_Name);
 133    end Get_Attribute_Id;
 134
 135    -----------------------
 136    -- Get_Convention_Id --
 137    -----------------------
 138
 139    function Get_Convention_Id (N : Name_Id) return Convention_Id is
 140    begin
 141       case N is
 142          when Name_Ada        => return Convention_Ada;
 143          when Name_Assembler  => return Convention_Assembler;
 144          when Name_C          => return Convention_C;
 145          when Name_CIL        => return Convention_CIL;
 146          when Name_COBOL      => return Convention_COBOL;
 147          when Name_CPP        => return Convention_CPP;
 148          when Name_Fortran    => return Convention_Fortran;
 149          when Name_Intrinsic  => return Convention_Intrinsic;
 150          when Name_Java       => return Convention_Java;
 151          when Name_Stdcall    => return Convention_Stdcall;
 152          when Name_Stubbed    => return Convention_Stubbed;
 153
 154          --  If no direct match, then we must have a convention
 155          --  identifier pragma that has specified this name.
 156
 157          when others          =>
 158             for J in 1 .. Convention_Identifiers.Last loop
 159                if N = Convention_Identifiers.Table (J).Name then
 160                   return Convention_Identifiers.Table (J).Convention;
 161                end if;
 162             end loop;
 163
 164             raise Program_Error;
 165       end case;
 166    end Get_Convention_Id;
 167
 168    -------------------------
 169    -- Get_Convention_Name --
 170    -------------------------
 171
 172    function Get_Convention_Name (C : Convention_Id) return Name_Id is
 173    begin
 174       case C is
 175          when Convention_Ada       => return Name_Ada;
 176          when Convention_Assembler => return Name_Assembler;
 177          when Convention_C         => return Name_C;
 178          when Convention_CIL       => return Name_CIL;
 179          when Convention_COBOL     => return Name_COBOL;
 180          when Convention_CPP       => return Name_CPP;
 181          when Convention_Entry     => return Name_Entry;
 182          when Convention_Fortran   => return Name_Fortran;
 183          when Convention_Intrinsic => return Name_Intrinsic;
 184          when Convention_Java      => return Name_Java;
 185          when Convention_Protected => return Name_Protected;
 186          when Convention_Stdcall   => return Name_Stdcall;
 187          when Convention_Stubbed   => return Name_Stubbed;
 188       end case;
 189    end Get_Convention_Name;
 190
 191    ---------------------------
 192    -- Get_Locking_Policy_Id --
 193    ---------------------------
 194
 195    function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
 196    begin
 197       return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
 198    end Get_Locking_Policy_Id;
 199
 200    -------------------
 201    -- Get_Pragma_Id --
 202    -------------------
 203
 204    function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
 205    begin
 206       if N = Name_AST_Entry then
 207          return Pragma_AST_Entry;
 208       elsif N = Name_Fast_Math then
 209          return Pragma_Fast_Math;
 210       elsif N = Name_Interface then
 211          return Pragma_Interface;
 212       elsif N = Name_Priority then
 213          return Pragma_Priority;
 214       elsif N = Name_Relative_Deadline then
 215          return Pragma_Relative_Deadline;
 216       elsif N = Name_Storage_Size then
 217          return Pragma_Storage_Size;
 218       elsif N = Name_Storage_Unit then
 219          return Pragma_Storage_Unit;
 220       elsif N not in First_Pragma_Name .. Last_Pragma_Name then
 221          return Unknown_Pragma;
 222       else
 223          return Pragma_Id'Val (N - First_Pragma_Name);
 224       end if;
 225    end Get_Pragma_Id;
 226
 227    ---------------------------
 228    -- Get_Queuing_Policy_Id --
 229    ---------------------------
 230
 231    function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
 232    begin
 233       return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
 234    end Get_Queuing_Policy_Id;
 235
 236    ------------------------------------
 237    -- Get_Task_Dispatching_Policy_Id --
 238    ------------------------------------
 239
 240    function Get_Task_Dispatching_Policy_Id
 241      (N : Name_Id) return Task_Dispatching_Policy_Id
 242    is
 243    begin
 244       return Task_Dispatching_Policy_Id'Val
 245         (N - First_Task_Dispatching_Policy_Name);
 246    end Get_Task_Dispatching_Policy_Id;
 247
 248    ----------------
 249    -- Initialize --
 250    ----------------
 251
 252    procedure Initialize is
 253       P_Index      : Natural;
 254       Discard_Name : Name_Id;
 255
 256    begin
 257       P_Index := Preset_Names'First;
 258       loop
 259          Name_Len := 0;
 260          while Preset_Names (P_Index) /= '#' loop
 261             Name_Len := Name_Len + 1;
 262             Name_Buffer (Name_Len) := Preset_Names (P_Index);
 263             P_Index := P_Index + 1;
 264          end loop;
 265
 266          --  We do the Name_Find call to enter the name into the table, but
 267          --  we don't need to do anything with the result, since we already
 268          --  initialized all the preset names to have the right value (we
 269          --  are depending on the order of the names and Preset_Names).
 270
 271          Discard_Name := Name_Find;
 272          P_Index := P_Index + 1;
 273          exit when Preset_Names (P_Index) = '#';
 274       end loop;
 275
 276       --  Make sure that number of names in standard table is correct. If
 277       --  this check fails, run utility program XSNAMES to construct a new
 278       --  properly matching version of the body.
 279
 280       pragma Assert (Discard_Name = Last_Predefined_Name);
 281
 282       --  Initialize the convention identifiers table with the standard
 283       --  set of synonyms that we recognize for conventions.
 284
 285       Convention_Identifiers.Init;
 286
 287       Convention_Identifiers.Append ((Name_Asm,         Convention_Assembler));
 288       Convention_Identifiers.Append ((Name_Assembly,    Convention_Assembler));
 289
 290       Convention_Identifiers.Append ((Name_Default,     Convention_C));
 291       Convention_Identifiers.Append ((Name_External,    Convention_C));
 292
 293       Convention_Identifiers.Append ((Name_C_Plus_Plus, Convention_CPP));
 294
 295       Convention_Identifiers.Append ((Name_DLL,         Convention_Stdcall));
 296       Convention_Identifiers.Append ((Name_Win32,       Convention_Stdcall));
 297    end Initialize;
 298
 299    -----------------------
 300    -- Is_Attribute_Name --
 301    -----------------------
 302
 303    function Is_Attribute_Name (N : Name_Id) return Boolean is
 304    begin
 305       return N in First_Attribute_Name .. Last_Attribute_Name;
 306    end Is_Attribute_Name;
 307
 308    ----------------------------------
 309    -- Is_Configuration_Pragma_Name --
 310    ----------------------------------
 311
 312    function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
 313    begin
 314       return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
 315         or else N = Name_Fast_Math;
 316    end Is_Configuration_Pragma_Name;
 317
 318    ------------------------
 319    -- Is_Convention_Name --
 320    ------------------------
 321
 322    function Is_Convention_Name (N : Name_Id) return Boolean is
 323    begin
 324       --  Check if this is one of the standard conventions
 325
 326       if N in First_Convention_Name .. Last_Convention_Name
 327         or else N = Name_C
 328       then
 329          return True;
 330
 331       --  Otherwise check if it is in convention identifier table
 332
 333       else
 334          for J in 1 .. Convention_Identifiers.Last loop
 335             if N = Convention_Identifiers.Table (J).Name then
 336                return True;
 337             end if;
 338          end loop;
 339
 340          return False;
 341       end if;
 342    end Is_Convention_Name;
 343
 344    ------------------------------
 345    -- Is_Entity_Attribute_Name --
 346    ------------------------------
 347
 348    function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
 349    begin
 350       return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
 351    end Is_Entity_Attribute_Name;
 352
 353    --------------------------------
 354    -- Is_Function_Attribute_Name --
 355    --------------------------------
 356
 357    function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
 358    begin
 359       return N in
 360         First_Renamable_Function_Attribute ..
 361           Last_Renamable_Function_Attribute;
 362    end Is_Function_Attribute_Name;
 363
 364    ---------------------
 365    -- Is_Keyword_Name --
 366    ---------------------
 367
 368    function Is_Keyword_Name (N : Name_Id) return Boolean is
 369    begin
 370       return Get_Name_Table_Byte (N) /= 0
 371         and then (Ada_Version >= Ada_95
 372                   or else N not in Ada_95_Reserved_Words)
 373         and then (Ada_Version >= Ada_05
 374                   or else N not in Ada_2005_Reserved_Words);
 375    end Is_Keyword_Name;
 376
 377    ----------------------------
 378    -- Is_Locking_Policy_Name --
 379    ----------------------------
 380
 381    function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
 382    begin
 383       return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
 384    end Is_Locking_Policy_Name;
 385
 386    -----------------------------
 387    -- Is_Operator_Symbol_Name --
 388    -----------------------------
 389
 390    function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
 391    begin
 392       return N in First_Operator_Name .. Last_Operator_Name;
 393    end Is_Operator_Symbol_Name;
 394
 395    --------------------
 396    -- Is_Pragma_Name --
 397    --------------------
 398
 399    function Is_Pragma_Name (N : Name_Id) return Boolean is
 400    begin
 401       return N in First_Pragma_Name .. Last_Pragma_Name
 402         or else N = Name_AST_Entry
 403         or else N = Name_Fast_Math
 404         or else N = Name_Interface
 405         or else N = Name_Relative_Deadline
 406         or else N = Name_Priority
 407         or else N = Name_Storage_Size
 408         or else N = Name_Storage_Unit;
 409    end Is_Pragma_Name;
 410
 411    ---------------------------------
 412    -- Is_Procedure_Attribute_Name --
 413    ---------------------------------
 414
 415    function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
 416    begin
 417       return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
 418    end Is_Procedure_Attribute_Name;
 419
 420    ----------------------------
 421    -- Is_Queuing_Policy_Name --
 422    ----------------------------
 423
 424    function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
 425    begin
 426       return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
 427    end Is_Queuing_Policy_Name;
 428
 429    -------------------------------------
 430    -- Is_Task_Dispatching_Policy_Name --
 431    -------------------------------------
 432
 433    function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
 434    begin
 435       return N in First_Task_Dispatching_Policy_Name ..
 436                   Last_Task_Dispatching_Policy_Name;
 437    end Is_Task_Dispatching_Policy_Name;
 438
 439    ----------------------------
 440    -- Is_Type_Attribute_Name --
 441    ----------------------------
 442
 443    function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
 444    begin
 445       return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
 446    end Is_Type_Attribute_Name;
 447
 448    ----------------------------------
 449    -- Record_Convention_Identifier --
 450    ----------------------------------
 451
 452    procedure Record_Convention_Identifier
 453      (Id         : Name_Id;
 454       Convention : Convention_Id)
 455    is
 456    begin
 457       Convention_Identifiers.Append ((Id, Convention));
 458    end Record_Convention_Identifier;
 459
 460 end Snames;