Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                               S N A M E S                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, 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    --

-- .                                          --

--                                                                          --

-- 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_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_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_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_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

      --  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 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)

        and then (Ada_Version >= Ada_2012

                   or else N not in Ada_2012_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;