summaryrefslogtreecommitdiff
path: root/gcc/ada/snames.adb-tmpl
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/snames.adb-tmpl')
-rw-r--r--gcc/ada/snames.adb-tmpl458
1 files changed, 458 insertions, 0 deletions
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
new file mode 100644
index 000000000..164b11d35
--- /dev/null
+++ b/gcc/ada/snames.adb-tmpl
@@ -0,0 +1,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;