Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P R J . A T T R                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2001-2009, 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 Osint;

with Prj.Com; use Prj.Com;

with GNAT.Case_Util; use GNAT.Case_Util;

package body Prj.Attr is

   use GNAT;

   --  Data for predefined attributes and packages

   --  Names are in lower case and end with '#'

   --  Package names are preceded by 'P'

   --  Attribute names are preceded by two or three letters:

   --  The first letter is one of

   --    'S' for Single

   --    's' for Single with optional index

   --    'L' for List

   --    'l' for List of strings with optional indexes

   --  The second letter is one of

   --    'V' for single variable

   --    'A' for associative array

   --    'a' for case insensitive associative array

   --    'b' for associative array, case insensitive if file names are case

   --        insensitive

   --    'c' same as 'b', with optional index

   --  The third optional letter is

   --     'R' to indicate that the attribute is read-only

   --     'O' to indicate that others is allowed as an index for an associative

   --     array

   --  End is indicated by two consecutive '#'

   Initialization_Data : constant String :=

   --  project level attributes

   --  General

   "SVRname#" &

   "SVRproject_dir#" &

   "lVmain#" &

   "LVlanguages#" &

   "SVmain_language#" &

   "Lbroots#" &

   "SVexternally_built#" &

   --  Directories

   "SVobject_dir#" &

   "SVexec_dir#" &

   "LVsource_dirs#" &

   "Lainherit_source_path#" &

   "LVexcluded_source_dirs#" &

   --  Source files

   "LVsource_files#" &

   "LVlocally_removed_files#" &

   "LVexcluded_source_files#" &

   "SVsource_list_file#" &

   "SVexcluded_source_list_file#" &

   "LVinterfaces#" &

   --  Libraries

   "SVlibrary_dir#" &

   "SVlibrary_name#" &

   "SVlibrary_kind#" &

   "SVlibrary_version#" &

   "LVlibrary_interface#" &

   "SVlibrary_auto_init#" &

   "LVlibrary_options#" &

   "SVlibrary_src_dir#" &

   "SVlibrary_ali_dir#" &

   "SVlibrary_gcc#" &

   "SVlibrary_symbol_file#" &

   "SVlibrary_symbol_policy#" &

   "SVlibrary_reference_symbol_file#" &

   --  Configuration - General

   "SVdefault_language#" &

   "LVrun_path_option#" &

   "SVrun_path_origin#" &

   "SVseparate_run_path_options#" &

   "Satoolchain_version#" &

   "Satoolchain_description#" &

   "Saobject_generated#" &

   "Saobjects_linked#" &

   "SVtarget#" &

   --  Configuration - Libraries

   "SVlibrary_builder#" &

   "SVlibrary_support#" &

   --  Configuration - Archives

   "LVarchive_builder#" &

   "LVarchive_builder_append_option#" &

   "LVarchive_indexer#" &

   "SVarchive_suffix#" &

   "LVlibrary_partial_linker#" &

   --  Configuration - Shared libraries

   "SVshared_library_prefix#" &

   "SVshared_library_suffix#" &

   "SVsymbolic_link_supported#" &

   "SVlibrary_major_minor_id_supported#" &

   "SVlibrary_auto_init_supported#" &

   "LVshared_library_minimum_switches#" &

   "LVlibrary_version_switches#" &

   "SVlibrary_install_name_option#" &

   "Saruntime_library_dir#" &

   "Saruntime_source_dir#" &

   --  package Naming

   "Pnaming#" &

   "Saspecification_suffix#" &

   "Saspec_suffix#" &

   "Saimplementation_suffix#" &

   "Sabody_suffix#" &

   "SVseparate_suffix#" &

   "SVcasing#" &

   "SVdot_replacement#" &

   "sAspecification#" &

   "sAspec#" &

   "sAimplementation#" &

   "sAbody#" &

   "Laspecification_exceptions#" &

   "Laimplementation_exceptions#" &

   --  package Compiler

   "Pcompiler#" &

   "Ladefault_switches#" &

   "LcOswitches#" &

   "SVlocal_configuration_pragmas#" &

   "Salocal_config_file#" &

   --  Configuration - Compiling

   "Sadriver#" &

   "Larequired_switches#" &

   "Laleading_required_switches#" &

   "Latrailing_required_switches#" &

   "Lapic_option#" &

   "Sapath_syntax#" &

   "Saobject_file_suffix#" &

   "Laobject_file_switches#" &

   "Lamulti_unit_switches#" &

   "Samulti_unit_object_separator#" &

   --  Configuration - Mapping files

   "Lamapping_file_switches#" &

   "Samapping_spec_suffix#" &

   "Samapping_body_suffix#" &

   --  Configuration - Config files

   "Laconfig_file_switches#" &

   "Saconfig_body_file_name#" &

   "Saconfig_body_file_name_index#" &

   "Saconfig_body_file_name_pattern#" &

   "Saconfig_spec_file_name#" &

   "Saconfig_spec_file_name_index#" &

   "Saconfig_spec_file_name_pattern#" &

   "Saconfig_file_unique#" &

   --  Configuration - Dependencies

   "Ladependency_switches#" &

   "Ladependency_driver#" &

   --  Configuration - Search paths

   "Lainclude_switches#" &

   "Sainclude_path#" &

   "Sainclude_path_file#" &

   --  package Builder

   "Pbuilder#" &

   "Ladefault_switches#" &

   "LcOswitches#" &

   "Lcglobal_compilation_switches#" &

   "Scexecutable#" &

   "SVexecutable_suffix#" &

   "SVglobal_configuration_pragmas#" &

   "Saglobal_config_file#" &

   --  package gnatls

   "Pgnatls#" &

   "LVswitches#" &

   --  package Binder

   "Pbinder#" &

   "Ladefault_switches#" &

   "LcOswitches#" &

   --  Configuration - Binding

   "Sadriver#" &

   "Larequired_switches#" &

   "Saprefix#" &

   "Saobjects_path#" &

   "Saobjects_path_file#" &

   --  package Linker

   "Plinker#" &

   "LVrequired_switches#" &

   "Ladefault_switches#" &

   "LcOswitches#" &

   "LVlinker_options#" &

   "SVmap_file_option#" &

   --  Configuration - Linking

   "SVdriver#" &

   "LVexecutable_switch#" &

   "SVlib_dir_switch#" &

   "SVlib_name_switch#" &

   --  Configuration - Response files

   "SVmax_command_line_length#" &

   "SVresponse_file_format#" &

   "LVresponse_file_switches#" &

   --  package Cross_Reference

   "Pcross_reference#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Finder

   "Pfinder#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Pretty_Printer

   "Ppretty_printer#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package gnatstub

   "Pgnatstub#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Check

   "Pcheck#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Synchronize

   "Psynchronize#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Eliminate

   "Peliminate#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Metrics

   "Pmetrics#" &

   "Ladefault_switches#" &

   "LbOswitches#" &

   --  package Ide

   "Pide#" &

   "Ladefault_switches#" &

   "SVremote_host#" &

   "SVprogram_host#" &

   "SVcommunication_protocol#" &

   "Sacompiler_command#" &

   "SVdebugger_command#" &

   "SVgnatlist#" &

   "SVvcs_kind#" &

   "SVvcs_file_check#" &

   "SVvcs_log_check#" &

   --  package Stack

   "Pstack#" &

   "LVswitches#" &

   "#";

   Initialized : Boolean := False;

   --  A flag to avoid multiple initialization

   Package_Names     : String_List_Access := new Strings.String_List (1 .. 20);

   Last_Package_Name : Natural := 0;

   --  Package_Names (1 .. Last_Package_Name) contains the list of the known

   --  package names, coming from the Initialization_Data string or from

   --  calls to one of the two procedures Register_New_Package.

   procedure Add_Package_Name (Name : String);

   --  Add a package name in the Package_Name list, extending it, if necessary

   function Name_Id_Of (Name : String) return Name_Id;

   --  Returns the Name_Id for Name in lower case

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

   -- Add_Package_Name --

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

   procedure Add_Package_Name (Name : String) is

   begin

      if Last_Package_Name = Package_Names'Last then

         declare

            New_List : constant Strings.String_List_Access :=

                         new Strings.String_List (1 .. Package_Names'Last * 2);

         begin

            New_List (Package_Names'Range) := Package_Names.all;

            Package_Names := New_List;

         end;

      end if;

      Last_Package_Name := Last_Package_Name + 1;

      Package_Names (Last_Package_Name) := new String'(Name);

   end Add_Package_Name;

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

   -- Attribute_Kind_Of --

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

   function Attribute_Kind_Of

     (Attribute : Attribute_Node_Id) return Attribute_Kind

   is

   begin

      if Attribute = Empty_Attribute then

         return Unknown;

      else

         return Attrs.Table (Attribute.Value).Attr_Kind;

      end if;

   end Attribute_Kind_Of;

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

   -- Attribute_Name_Of --

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

   function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is

   begin

      if Attribute = Empty_Attribute then

         return No_Name;

      else

         return Attrs.Table (Attribute.Value).Name;

      end if;

   end Attribute_Name_Of;

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

   -- Attribute_Node_Id_Of --

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

   function Attribute_Node_Id_Of

     (Name        : Name_Id;

      Starting_At : Attribute_Node_Id) return Attribute_Node_Id

   is

      Id : Attr_Node_Id := Starting_At.Value;

   begin

      while Id /= Empty_Attr

        and then Attrs.Table (Id).Name /= Name

      loop

         Id := Attrs.Table (Id).Next;

      end loop;

      return (Value => Id);

   end Attribute_Node_Id_Of;

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

   -- Initialize --

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

   procedure Initialize is

      Start             : Positive          := Initialization_Data'First;

      Finish            : Positive          := Start;

      Current_Package   : Pkg_Node_Id       := Empty_Pkg;

      Current_Attribute : Attr_Node_Id      := Empty_Attr;

      Is_An_Attribute   : Boolean           := False;

      Var_Kind          : Variable_Kind     := Undefined;

      Optional_Index    : Boolean           := False;

      Attr_Kind         : Attribute_Kind    := Single;

      Package_Name      : Name_Id           := No_Name;

      Attribute_Name    : Name_Id           := No_Name;

      First_Attribute   : Attr_Node_Id      := Attr.First_Attribute;

      Read_Only         : Boolean;

      Others_Allowed    : Boolean;

      function Attribute_Location return String;

      --  Returns a string depending if we are in the project level attributes

      --  or in the attributes of a package.

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

      -- Attribute_Location --

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

      function Attribute_Location return String is

      begin

         if Package_Name = No_Name then

            return "project level attributes";

         else

            return "attribute of package """ &

            Get_Name_String (Package_Name) & """";

         end if;

      end Attribute_Location;

   --  Start of processing for Initialize

   begin

      --  Don't allow Initialize action to be repeated

      if Initialized then

         return;

      end if;

      --  Make sure the two tables are empty

      Attrs.Init;

      Package_Attributes.Init;

      while Initialization_Data (Start) /= '#' loop

         Is_An_Attribute := True;

         case Initialization_Data (Start) is

            when 'P' =>

               --  New allowed package

               Start := Start + 1;

               Finish := Start;

               while Initialization_Data (Finish) /= '#' loop

                  Finish := Finish + 1;

               end loop;

               Package_Name :=

                 Name_Id_Of (Initialization_Data (Start .. Finish - 1));

               for Index in First_Package .. Package_Attributes.Last loop

                  if Package_Name = Package_Attributes.Table (Index).Name then

                     Osint.Fail ("duplicate name """

                                 & Initialization_Data (Start .. Finish - 1)

                                 & """ in predefined packages.");

                  end if;

               end loop;

               Is_An_Attribute := False;

               Current_Attribute := Empty_Attr;

               Package_Attributes.Increment_Last;

               Current_Package := Package_Attributes.Last;

               Package_Attributes.Table (Current_Package) :=

                 (Name             => Package_Name,

                  Known            => True,

                  First_Attribute  => Empty_Attr);

               Start := Finish + 1;

               Add_Package_Name (Get_Name_String (Package_Name));

            when 'S' =>

               Var_Kind       := Single;

               Optional_Index := False;

            when 's' =>

               Var_Kind       := Single;

               Optional_Index := True;

            when 'L' =>

               Var_Kind       := List;

               Optional_Index := False;

            when 'l' =>

               Var_Kind         := List;

               Optional_Index := True;

            when others =>

               raise Program_Error;

         end case;

         if Is_An_Attribute then

            --  New attribute

            Start := Start + 1;

            case Initialization_Data (Start) is

               when 'V' =>

                  Attr_Kind := Single;

               when 'A' =>

                  Attr_Kind := Associative_Array;

               when 'a' =>

                  Attr_Kind := Case_Insensitive_Associative_Array;

               when 'b' =>

                  if Osint.File_Names_Case_Sensitive then

                     Attr_Kind := Associative_Array;

                  else

                     Attr_Kind := Case_Insensitive_Associative_Array;

                  end if;

               when 'c' =>

                  if Osint.File_Names_Case_Sensitive then

                     Attr_Kind := Optional_Index_Associative_Array;

                  else

                     Attr_Kind :=

                       Optional_Index_Case_Insensitive_Associative_Array;

                  end if;

               when others =>

                  raise Program_Error;

            end case;

            Start := Start + 1;

            Read_Only := False;

            Others_Allowed := False;

            if Initialization_Data (Start) = 'R' then

               Read_Only := True;

               Start := Start + 1;

            elsif Initialization_Data (Start) = 'O' then

               Others_Allowed := True;

               Start := Start + 1;

            end if;

            Finish := Start;

            while Initialization_Data (Finish) /= '#' loop

               Finish := Finish + 1;

            end loop;

            Attribute_Name :=

              Name_Id_Of (Initialization_Data (Start .. Finish - 1));

            Attrs.Increment_Last;

            if Current_Attribute = Empty_Attr then

               First_Attribute := Attrs.Last;

               if Current_Package /= Empty_Pkg then

                  Package_Attributes.Table (Current_Package).First_Attribute

                    := Attrs.Last;

               end if;

            else

               --  Check that there are no duplicate attributes

               for Index in First_Attribute .. Attrs.Last - 1 loop

                  if Attribute_Name = Attrs.Table (Index).Name then

                     Osint.Fail ("duplicate attribute """

                                 & Initialization_Data (Start .. Finish - 1)

                                 & """ in " & Attribute_Location);

                  end if;

               end loop;

               Attrs.Table (Current_Attribute).Next :=

                 Attrs.Last;

            end if;

            Current_Attribute := Attrs.Last;

            Attrs.Table (Current_Attribute) :=

              (Name           => Attribute_Name,

               Var_Kind       => Var_Kind,

               Optional_Index => Optional_Index,

               Attr_Kind      => Attr_Kind,

               Read_Only      => Read_Only,

               Others_Allowed => Others_Allowed,

               Next           => Empty_Attr);

            Start := Finish + 1;

         end if;

      end loop;

      Initialized := True;

   end Initialize;

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

   -- Is_Read_Only --

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

   function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is

   begin

      return Attrs.Table (Attribute.Value).Read_Only;

   end Is_Read_Only;

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

   -- Name_Id_Of --

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

   function Name_Id_Of (Name : String) return Name_Id is

   begin

      Name_Len := 0;

      Add_Str_To_Name_Buffer (Name);

      To_Lower (Name_Buffer (1 .. Name_Len));

      return Name_Find;

   end Name_Id_Of;

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

   -- Next_Attribute --

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

   function Next_Attribute

     (After : Attribute_Node_Id) return Attribute_Node_Id

   is

   begin

      if After = Empty_Attribute then

         return Empty_Attribute;

      else

         return (Value => Attrs.Table (After.Value).Next);

      end if;

   end Next_Attribute;

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

   -- Optional_Index_Of --

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

   function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is

   begin

      if Attribute = Empty_Attribute then

         return False;

      else

         return Attrs.Table (Attribute.Value).Optional_Index;

      end if;

   end Optional_Index_Of;

   function Others_Allowed_For

     (Attribute : Attribute_Node_Id) return Boolean

   is

   begin

      if Attribute = Empty_Attribute then

         return False;

      else

         return Attrs.Table (Attribute.Value).Others_Allowed;

      end if;

   end Others_Allowed_For;

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

   -- Package_Name_List --

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

   function Package_Name_List return Strings.String_List is

   begin

      return Package_Names (1 .. Last_Package_Name);

   end Package_Name_List;

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

   -- Package_Node_Id_Of --

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

   function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is

   begin

      for Index in Package_Attributes.First .. Package_Attributes.Last loop

         if Package_Attributes.Table (Index).Name = Name then

            if Package_Attributes.Table (Index).Known then

               return (Value => Index);

            else

               return Unknown_Package;

            end if;

         end if;

      end loop;

      --  If there is no package with this name, return Empty_Package

      return Empty_Package;

   end Package_Node_Id_Of;

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

   -- Register_New_Attribute --

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

   procedure Register_New_Attribute

     (Name               : String;

      In_Package         : Package_Node_Id;

      Attr_Kind          : Defined_Attribute_Kind;

      Var_Kind           : Defined_Variable_Kind;

      Index_Is_File_Name : Boolean := False;

      Opt_Index          : Boolean := False)

   is

      Attr_Name       : Name_Id;

      First_Attr      : Attr_Node_Id := Empty_Attr;

      Curr_Attr       : Attr_Node_Id;

      Real_Attr_Kind  : Attribute_Kind;

   begin

      if Name'Length = 0 then

         Fail ("cannot register an attribute with no name");

         raise Project_Error;

      end if;

      if In_Package = Empty_Package then

         Fail ("attempt to add attribute """

               & Name

               & """ to an undefined package");

         raise Project_Error;

      end if;

      Attr_Name := Name_Id_Of (Name);

      First_Attr :=

        Package_Attributes.Table (In_Package.Value).First_Attribute;

      --  Check if attribute name is a duplicate

      Curr_Attr := First_Attr;

      while Curr_Attr /= Empty_Attr loop

         if Attrs.Table (Curr_Attr).Name = Attr_Name then

            Fail ("duplicate attribute name """

                  & Name

                  & """ in package """

                  & Get_Name_String

                     (Package_Attributes.Table (In_Package.Value).Name)

                  & """");

            raise Project_Error;

         end if;

         Curr_Attr := Attrs.Table (Curr_Attr).Next;

      end loop;

      Real_Attr_Kind := Attr_Kind;

      --  If Index_Is_File_Name, change the attribute kind if necessary

      if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then

         case Attr_Kind is

            when Associative_Array =>

               Real_Attr_Kind := Case_Insensitive_Associative_Array;

            when Optional_Index_Associative_Array =>

               Real_Attr_Kind :=

                 Optional_Index_Case_Insensitive_Associative_Array;

            when others =>

               null;

         end case;

      end if;

      --  Add the new attribute

      Attrs.Increment_Last;

      Attrs.Table (Attrs.Last) :=

        (Name           => Attr_Name,

         Var_Kind       => Var_Kind,

         Optional_Index => Opt_Index,

         Attr_Kind      => Real_Attr_Kind,

         Read_Only      => False,

         Others_Allowed => False,

         Next           => First_Attr);

      Package_Attributes.Table (In_Package.Value).First_Attribute :=

        Attrs.Last;

   end Register_New_Attribute;

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

   -- Register_New_Package --

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

   procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is

      Pkg_Name : Name_Id;

   begin

      if Name'Length = 0 then

         Fail ("cannot register a package with no name");

         Id := Empty_Package;