------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S N A M E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2021, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; 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) -- xxxFD finalize address routine for type xxx (Exp_TSS) -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS) -- xxxIP initialization procedure for type xxx (Exp_TSS) -- xxxIC init C++ dispatch tables 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) -- xxxPI Put_Image 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 if N = Name_CPU then return Attribute_CPU; elsif N = Name_Dispatching_Domain then return Attribute_Dispatching_Domain; elsif N = Name_Interrupt_Priority then return Attribute_Interrupt_Priority; else return Attribute_Id'Val (N - First_Attribute_Name); end if; 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_Ada_Pass_By_Copy => return Convention_Ada_Pass_By_Copy; when Name_Ada_Pass_By_Reference => return Convention_Ada_Pass_By_Reference; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; when Name_C_Variadic_0 => return Convention_C_Variadic_0; when Name_C_Variadic_1 => return Convention_C_Variadic_1; when Name_C_Variadic_2 => return Convention_C_Variadic_2; when Name_C_Variadic_3 => return Convention_C_Variadic_3; when Name_C_Variadic_4 => return Convention_C_Variadic_4; when Name_C_Variadic_5 => return Convention_C_Variadic_5; when Name_C_Variadic_6 => return Convention_C_Variadic_6; when Name_C_Variadic_7 => return Convention_C_Variadic_7; when Name_C_Variadic_8 => return Convention_C_Variadic_8; when Name_C_Variadic_9 => return Convention_C_Variadic_9; when Name_C_Variadic_10 => return Convention_C_Variadic_10; when Name_C_Variadic_11 => return Convention_C_Variadic_11; when Name_C_Variadic_12 => return Convention_C_Variadic_12; when Name_C_Variadic_13 => return Convention_C_Variadic_13; when Name_C_Variadic_14 => return Convention_C_Variadic_14; when Name_C_Variadic_15 => return Convention_C_Variadic_15; when Name_C_Variadic_16 => return Convention_C_Variadic_16; 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_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_Ada_Pass_By_Copy => return Name_Ada_Pass_By_Copy; when Convention_Ada_Pass_By_Reference => return Name_Ada_Pass_By_Reference; when Convention_Assembler => return Name_Assembler; when Convention_C => return Name_C; when Convention_C_Variadic_0 => return Name_C_Variadic_0; when Convention_C_Variadic_1 => return Name_C_Variadic_1; when Convention_C_Variadic_2 => return Name_C_Variadic_2; when Convention_C_Variadic_3 => return Name_C_Variadic_3; when Convention_C_Variadic_4 => return Name_C_Variadic_4; when Convention_C_Variadic_5 => return Name_C_Variadic_5; when Convention_C_Variadic_6 => return Name_C_Variadic_6; when Convention_C_Variadic_7 => return Name_C_Variadic_7; when Convention_C_Variadic_8 => return Name_C_Variadic_8; when Convention_C_Variadic_9 => return Name_C_Variadic_9; when Convention_C_Variadic_10 => return Name_C_Variadic_10; when Convention_C_Variadic_11 => return Name_C_Variadic_11; when Convention_C_Variadic_12 => return Name_C_Variadic_12; when Convention_C_Variadic_13 => return Name_C_Variadic_13; when Convention_C_Variadic_14 => return Name_C_Variadic_14; when Convention_C_Variadic_15 => return Name_C_Variadic_15; when Convention_C_Variadic_16 => return Name_C_Variadic_16; 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_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 case N is when Name_CPU => return Pragma_CPU; when Name_Default_Scalar_Storage_Order => return Pragma_Default_Scalar_Storage_Order; when Name_Dispatching_Domain => return Pragma_Dispatching_Domain; when Name_Fast_Math => return Pragma_Fast_Math; when Name_Interface => return Pragma_Interface; when Name_Interrupt_Priority => return Pragma_Interrupt_Priority; when Name_Preelaborable_Initialization => return Pragma_Preelaborable_Initialization; when Name_Priority => return Pragma_Priority; when Name_Secondary_Stack_Size => return Pragma_Secondary_Stack_Size; when Name_Storage_Size => return Pragma_Storage_Size; when Name_Storage_Unit => return Pragma_Storage_Unit; when First_Pragma_Name .. Last_Pragma_Name => return Pragma_Id'Val (N - First_Pragma_Name); when others => return Unknown_Pragma; end case; 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 -- Don't consider Name_Elab_Subp_Body to be a valid attribute name -- unless we are working in CodePeer mode. return N in First_Attribute_Name .. Last_Attribute_Name and then (CodePeer_Mode or else N /= Name_Elab_Subp_Body); end Is_Attribute_Name; ---------------------------------- -- Is_Configuration_Pragma_Name -- ---------------------------------- function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is begin return N in Configuration_Pragma_Names or else N = Name_Default_Scalar_Storage_Order 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 or else (Debug_Flag_Dot_DD and then N = Name_Overriding)) -- Accept 'overriding' keywords if -gnatd.D is used, -- for compatibility with Ada 95 compilers implementing -- only this Ada 2005 extension. and then (Ada_Version >= Ada_2012 or else N not in Ada_2012_Reserved_Words); end Is_Keyword_Name; -------------------------------- -- Is_Internal_Attribute_Name -- -------------------------------- function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is begin return N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name; end Is_Internal_Attribute_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_Partition_Elaboration_Policy_Name -- ------------------------------------------ function Is_Partition_Elaboration_Policy_Name (N : Name_Id) return Boolean is begin return N in First_Partition_Elaboration_Policy_Name .. Last_Partition_Elaboration_Policy_Name; end Is_Partition_Elaboration_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_CPU or else N = Name_Default_Scalar_Storage_Order or else N = Name_Dispatching_Domain or else N = Name_Fast_Math or else N = Name_Interface or else N = Name_Interrupt_Priority or else N = Name_Preelaborable_Initialization or else N = Name_Priority or else N = Name_Secondary_Stack_Size 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;