Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P R J . C O N F                             --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--            Copyright (C) 2006-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 Ada.Directories;  use Ada.Directories;

with GNAT.HTable;      use GNAT.HTable;

with Makeutl;          use Makeutl;

with MLib.Tgt;

with Opt;              use Opt;

with Output;           use Output;

with Prj.Env;

with Prj.Err;

with Prj.Part;

with Prj.PP;

with Prj.Proc;         use Prj.Proc;

with Prj.Tree;         use Prj.Tree;

with Prj.Util;         use Prj.Util;

with Prj;              use Prj;

with Snames;           use Snames;

with System.Case_Util; use System.Case_Util;

with System;

package body Prj.Conf is

   Auto_Cgpr : constant String := "auto.cgpr";

   Default_Name : constant String := "default.cgpr";

   --  Default configuration file that will be used if found

   Config_Project_Env_Var : constant String := "GPR_CONFIG";

   --  Name of the environment variable that provides the name of the

   --  configuration file to use.

   Gprconfig_Name : constant String := "gprconfig";

   package RTS_Languages is new GNAT.HTable.Simple_HTable

     (Header_Num => Prj.Header_Num,

      Element    => Name_Id,

      No_Element => No_Name,

      Key        => Name_Id,

      Hash       => Prj.Hash,

      Equal      => "=");

   --  Stores the runtime names for the various languages. This is in general

   --  set from a --RTS command line option.

   procedure Add_Attributes

     (Project_Tree : Project_Tree_Ref;

      Conf_Decl    : Declarations;

      User_Decl    : in out Declarations);

   --  Process the attributes in the config declarations.

   --  For single string values, if the attribute is not declared in the user

   --  declarations, declare it with the value in the config declarations.

   --  For string list values, prepend the value in the user declarations with

   --  the value in the config declarations.

   function Locate_Config_File (Name : String) return String_Access;

   --  Search for Name in the config files directory. Return full path if

   --  found, or null otherwise

   function Check_Target

     (Config_File        : Prj.Project_Id;

      Autoconf_Specified : Boolean;

      Project_Tree       : Prj.Project_Tree_Ref;

      Target             : String := "") return Boolean;

   --  Check that the config file's target matches Target.

   --  Target should be set to the empty string when the user did not specify

   --  a target. If the target in the configuration file is invalid, this

   --  function will raise Invalid_Config with an appropriate message.

   --  Autoconf_Specified should be set to True if the user has used --autoconf

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

   -- Add_Attributes --

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

   procedure Add_Attributes

     (Project_Tree : Project_Tree_Ref;

      Conf_Decl    : Declarations;

      User_Decl    : in out Declarations)

   is

      Conf_Attr_Id       : Variable_Id;

      Conf_Attr          : Variable;

      Conf_Array_Id      : Array_Id;

      Conf_Array         : Array_Data;

      Conf_Array_Elem_Id : Array_Element_Id;

      Conf_Array_Elem    : Array_Element;

      Conf_List          : String_List_Id;

      Conf_List_Elem     : String_Element;

      User_Attr_Id       : Variable_Id;

      User_Attr          : Variable;

      User_Array_Id      : Array_Id;

      User_Array         : Array_Data;

      User_Array_Elem_Id : Array_Element_Id;

      User_Array_Elem    : Array_Element;

   begin

      Conf_Attr_Id := Conf_Decl.Attributes;

      User_Attr_Id := User_Decl.Attributes;

      while Conf_Attr_Id /= No_Variable loop

         Conf_Attr :=

           Project_Tree.Variable_Elements.Table (Conf_Attr_Id);

         User_Attr :=

           Project_Tree.Variable_Elements.Table (User_Attr_Id);

         if not Conf_Attr.Value.Default then

            if User_Attr.Value.Default then

               --  No attribute declared in user project file: just copy the

               --  value of the configuration attribute.

               User_Attr.Value := Conf_Attr.Value;

               Project_Tree.Variable_Elements.Table (User_Attr_Id) :=

                 User_Attr;

            elsif User_Attr.Value.Kind = List

              and then Conf_Attr.Value.Values /= Nil_String

            then

               --  List attribute declared in both the user project and the

               --  configuration project: prepend the user list with the

               --  configuration list.

               declare

                  Conf_List : String_List_Id := Conf_Attr.Value.Values;

                  Conf_Elem : String_Element;

                  User_List : constant String_List_Id :=

                                User_Attr.Value.Values;

                  New_List : String_List_Id;

                  New_Elem : String_Element;

               begin

                  --  Create new list

                  String_Element_Table.Increment_Last

                    (Project_Tree.String_Elements);

                  New_List := String_Element_Table.Last

                    (Project_Tree.String_Elements);

                  --  Value of attribute is new list

                  User_Attr.Value.Values := New_List;

                  Project_Tree.Variable_Elements.Table (User_Attr_Id) :=

                    User_Attr;

                  loop

                     --  Get each element of configuration list

                     Conf_Elem :=

                       Project_Tree.String_Elements.Table (Conf_List);

                     New_Elem := Conf_Elem;

                     Conf_List := Conf_Elem.Next;

                     if Conf_List = Nil_String then

                        --  If it is the last element in the list, connect to

                        --  first element of user list, and we are done.

                        New_Elem.Next := User_List;

                        Project_Tree.String_Elements.Table

                          (New_List) := New_Elem;

                        exit;

                     else

                        --  If it is not the last element in the list, add to

                        --  new list.

                        String_Element_Table.Increment_Last

                          (Project_Tree.String_Elements);

                        New_Elem.Next :=

                          String_Element_Table.Last

                            (Project_Tree.String_Elements);

                        Project_Tree.String_Elements.Table

                          (New_List) := New_Elem;

                        New_List := New_Elem.Next;

                     end if;

                  end loop;

               end;

            end if;

         end if;

         Conf_Attr_Id := Conf_Attr.Next;

         User_Attr_Id := User_Attr.Next;

      end loop;

      Conf_Array_Id := Conf_Decl.Arrays;

      while Conf_Array_Id /= No_Array loop

         Conf_Array := Project_Tree.Arrays.Table (Conf_Array_Id);

         User_Array_Id := User_Decl.Arrays;

         while User_Array_Id /= No_Array loop

            User_Array := Project_Tree.Arrays.Table (User_Array_Id);

            exit when User_Array.Name = Conf_Array.Name;

            User_Array_Id := User_Array.Next;

         end loop;

         --  If this associative array does not exist in the user project file,

         --  do a shallow copy of the full associative array.

         if User_Array_Id = No_Array then

            Array_Table.Increment_Last (Project_Tree.Arrays);

            User_Array := Conf_Array;

            User_Array.Next := User_Decl.Arrays;

            User_Decl.Arrays := Array_Table.Last (Project_Tree.Arrays);

            Project_Tree.Arrays.Table (User_Decl.Arrays) := User_Array;

         else

            --  Otherwise, check each array element

            Conf_Array_Elem_Id := Conf_Array.Value;

            while Conf_Array_Elem_Id /= No_Array_Element loop

               Conf_Array_Elem :=

                 Project_Tree.Array_Elements.Table (Conf_Array_Elem_Id);

               User_Array_Elem_Id := User_Array.Value;

               while User_Array_Elem_Id /= No_Array_Element loop

                  User_Array_Elem :=

                    Project_Tree.Array_Elements.Table (User_Array_Elem_Id);

                  exit when User_Array_Elem.Index = Conf_Array_Elem.Index;

                  User_Array_Elem_Id := User_Array_Elem.Next;

               end loop;

               --  If the array element does not exist in the user array,

               --  insert a shallow copy of the conf array element in the

               --  user array.

               if User_Array_Elem_Id = No_Array_Element then

                  Array_Element_Table.Increment_Last

                    (Project_Tree.Array_Elements);

                  User_Array_Elem := Conf_Array_Elem;

                  User_Array_Elem.Next := User_Array.Value;

                  User_Array.Value :=

                    Array_Element_Table.Last (Project_Tree.Array_Elements);

                  Project_Tree.Array_Elements.Table (User_Array.Value) :=

                    User_Array_Elem;

                  Project_Tree.Arrays.Table (User_Array_Id) := User_Array;

               --  Otherwise, if the value is a string list, prepend the

               --  user array element with the conf array element value.

               elsif Conf_Array_Elem.Value.Kind = List then

                  Conf_List := Conf_Array_Elem.Value.Values;

                  if Conf_List /= Nil_String then

                     declare

                        Link     : constant String_List_Id :=

                                     User_Array_Elem.Value.Values;

                        Previous : String_List_Id := Nil_String;

                        Next     : String_List_Id;

                     begin

                        loop

                           Conf_List_Elem :=

                             Project_Tree.String_Elements.Table

                               (Conf_List);

                           String_Element_Table.Increment_Last

                             (Project_Tree.String_Elements);

                           Next :=

                             String_Element_Table.Last

                               (Project_Tree.String_Elements);

                           Project_Tree.String_Elements.Table (Next) :=

                             Conf_List_Elem;

                           if Previous = Nil_String then

                              User_Array_Elem.Value.Values := Next;

                              Project_Tree.Array_Elements.Table

                                (User_Array_Elem_Id) := User_Array_Elem;

                           else

                              Project_Tree.String_Elements.Table

                                (Previous).Next := Next;

                           end if;

                           Previous := Next;

                           Conf_List := Conf_List_Elem.Next;

                           if Conf_List = Nil_String then

                              Project_Tree.String_Elements.Table

                                (Previous).Next := Link;

                              exit;

                           end if;

                        end loop;

                     end;

                  end if;

               end if;

               Conf_Array_Elem_Id := Conf_Array_Elem.Next;

            end loop;

         end if;

         Conf_Array_Id := Conf_Array.Next;

      end loop;

   end Add_Attributes;

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

   -- Locate_Config_File --

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

   function Locate_Config_File (Name : String) return String_Access is

      Prefix_Path : constant String := Executable_Prefix_Path;

   begin

      if Prefix_Path'Length /= 0 then

         return Locate_Regular_File

           (Name,

            "." & Path_Separator &

            Prefix_Path & "share" & Directory_Separator & "gpr");

      else

         return Locate_Regular_File (Name, ".");

      end if;

   end Locate_Config_File;

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

   -- Check_Target --

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

   function Check_Target

     (Config_File  : Project_Id;

      Autoconf_Specified : Boolean;

      Project_Tree : Prj.Project_Tree_Ref;

      Target       : String := "") return Boolean

   is

      Variable : constant Variable_Value :=

                   Value_Of

                     (Name_Target, Config_File.Decl.Attributes, Project_Tree);

      Tgt_Name : Name_Id := No_Name;

      OK       : Boolean;

   begin

      if Variable /= Nil_Variable_Value and then not Variable.Default then

         Tgt_Name := Variable.Value;

      end if;

      if Target = "" then

         OK := not Autoconf_Specified or else Tgt_Name = No_Name;

      else

         OK := Tgt_Name /= No_Name

                 and then Target = Get_Name_String (Tgt_Name);

      end if;

      if not OK then

         if Autoconf_Specified then

            if Verbose_Mode then

               Write_Line ("inconsistent targets, performing autoconf");

            end if;

            return False;

         else

            if Tgt_Name /= No_Name then

               raise Invalid_Config

                 with "invalid target name """

                   & Get_Name_String (Tgt_Name) & """ in configuration";

            else

               raise Invalid_Config

                 with "no target specified in configuration file";

            end if;

         end if;

      end if;

      return True;

   end Check_Target;

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

   -- Get_Or_Create_Configuration_File --

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

   procedure Get_Or_Create_Configuration_File

     (Project                    : Project_Id;

      Project_Tree               : Project_Tree_Ref;

      Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;

      Allow_Automatic_Generation : Boolean;

      Config_File_Name           : String := "";

      Autoconf_Specified         : Boolean;

      Target_Name                : String := "";

      Normalized_Hostname        : String;

      Packages_To_Check          : String_List_Access := null;

      Config                     : out Prj.Project_Id;

      Config_File_Path           : out String_Access;

      Automatically_Generated    : out Boolean;

      Flags                      : Processing_Flags;

      On_Load_Config             : Config_File_Hook := null)

   is

      function Default_File_Name return String;

      --  Return the name of the default config file that should be tested

      procedure Do_Autoconf;

      --  Generate a new config file through gprconfig.

      --  In case of error, this raises the Invalid_Config exception with an

      --  appropriate message

      function Get_Config_Switches return Argument_List_Access;

      --  Return the --config switches to use for gprconfig

      function Might_Have_Sources (Project : Project_Id) return Boolean;

      --  True if the specified project might have sources (ie the user has not

      --  explicitly specified it. We haven't checked the file system, nor do

      --  we need to at this stage.

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

      -- Default_File_Name --

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

      function Default_File_Name return String is

         Ada_RTS : constant String := Runtime_Name_For (Name_Ada);

         Tmp     : String_Access;

      begin

         if Target_Name /= "" then

            if Ada_RTS /= "" then

               return Target_Name & '-' & Ada_RTS

                 & Config_Project_File_Extension;

            else

               return Target_Name & Config_Project_File_Extension;

            end if;

         elsif Ada_RTS /= "" then

            return Ada_RTS & Config_Project_File_Extension;

         else

            Tmp := Getenv (Config_Project_Env_Var);

            declare

               T : constant String := Tmp.all;

            begin

               Free (Tmp);

               if T'Length = 0 then

                  return Default_Name;

               else

                  return T;

               end if;

            end;

         end if;

      end Default_File_Name;

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

      -- Might_Have_Sources --

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

      function Might_Have_Sources (Project : Project_Id) return Boolean is

         Variable : Variable_Value;

      begin

         Variable :=

           Value_Of

             (Name_Source_Dirs,

              Project.Decl.Attributes,

              Project_Tree);

         if Variable = Nil_Variable_Value

           or else Variable.Default

           or else Variable.Values /= Nil_String

         then

            Variable :=

              Value_Of

                (Name_Source_Files,

                 Project.Decl.Attributes,

                 Project_Tree);

            return Variable = Nil_Variable_Value

              or else Variable.Default

              or else Variable.Values /= Nil_String;

         else

            return False;

         end if;

      end Might_Have_Sources;

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

      -- Get_Config_Switches --

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

      function Get_Config_Switches return Argument_List_Access is

         package Language_Htable is new GNAT.HTable.Simple_HTable

           (Header_Num => Prj.Header_Num,

            Element    => Name_Id,

            No_Element => No_Name,

            Key        => Name_Id,

            Hash       => Prj.Hash,

            Equal      => "=");

         --  Hash table to keep the languages used in the project tree

         IDE : constant Package_Id :=

                 Value_Of

                   (Name_Ide,

                    Project.Decl.Packages,

                    Project_Tree);

         Prj_Iter : Project_List;

         List     : String_List_Id;

         Elem     : String_Element;

         Lang     : Name_Id;

         Variable : Variable_Value;

         Name     : Name_Id;

         Count    : Natural;

         Result   : Argument_List_Access;

         Check_Default : Boolean;

      begin

         Prj_Iter := Project_Tree.Projects;

         while Prj_Iter /= null loop

            if Might_Have_Sources (Prj_Iter.Project) then

               Variable :=

                 Value_Of

                   (Name_Languages,

                    Prj_Iter.Project.Decl.Attributes,

                    Project_Tree);

               if Variable = Nil_Variable_Value

                 or else Variable.Default

               then

                  --  Languages is not declared. If it is not an extending

                  --  project, or if it extends a project with no Languages,

                  --  check for Default_Language.

                  Check_Default := Prj_Iter.Project.Extends = No_Project;

                  if not Check_Default then

                     Variable :=

                       Value_Of

                         (Name_Languages,

                          Prj_Iter.Project.Extends.Decl.Attributes,

                          Project_Tree);

                     Check_Default :=

                       Variable /= Nil_Variable_Value

                         and then Variable.Values = Nil_String;

                  end if;

                  if Check_Default then

                     Variable :=

                       Value_Of

                         (Name_Default_Language,

                          Prj_Iter.Project.Decl.Attributes,

                          Project_Tree);

                     if Variable /= Nil_Variable_Value

                       and then not Variable.Default

                     then

                        Get_Name_String (Variable.Value);

                        To_Lower (Name_Buffer (1 .. Name_Len));

                        Lang := Name_Find;

                        Language_Htable.Set (Lang, Lang);

                     else

                        --  If no default language is declared, default to Ada

                        Language_Htable.Set (Name_Ada, Name_Ada);

                     end if;

                  end if;

               elsif Variable.Values /= Nil_String then

                  --  Attribute Languages is declared with a non empty

                  --  list: put all the languages in Language_HTable.

                  List := Variable.Values;

                  while List /= Nil_String loop

                     Elem := Project_Tree.String_Elements.Table (List);

                     Get_Name_String (Elem.Value);

                     To_Lower (Name_Buffer (1 .. Name_Len));

                     Lang := Name_Find;

                     Language_Htable.Set (Lang, Lang);

                     List := Elem.Next;

                  end loop;

               end if;

            end if;

            Prj_Iter := Prj_Iter.Next;

         end loop;

         Name  := Language_Htable.Get_First;

         Count := 0;

         while Name /= No_Name loop

            Count := Count + 1;

            Name := Language_Htable.Get_Next;

         end loop;

         Result := new String_List (1 .. Count);

         Count := 1;

         Name  := Language_Htable.Get_First;

         while Name /= No_Name loop

            --  Check if IDE'Compiler_Command is declared for the language.

            --  If it is, use its value to invoke gprconfig.

            Variable :=

              Value_Of

                (Name,

                 Attribute_Or_Array_Name => Name_Compiler_Command,

                 In_Package              => IDE,

                 In_Tree                 => Project_Tree,

                 Force_Lower_Case_Index  => True);

            declare

               Config_Command : constant String :=

                 "--config=" & Get_Name_String (Name);

               Runtime_Name   : constant String :=

                 Runtime_Name_For (Name);

            begin

               if Variable = Nil_Variable_Value

                 or else Length_Of_Name (Variable.Value) = 0

               then

                  Result (Count) :=

                    new String'(Config_Command & ",," & Runtime_Name);

               else

                  declare

                     Compiler_Command : constant String :=

                       Get_Name_String (Variable.Value);

                  begin

                     if Is_Absolute_Path (Compiler_Command) then

                        Result (Count) :=

                          new String'

                            (Config_Command & ",," & Runtime_Name & "," &

                             Containing_Directory (Compiler_Command) & "," &

                             Simple_Name (Compiler_Command));

                     else

                        Result (Count) :=

                          new String'

                            (Config_Command & ",," & Runtime_Name & ",," &

                             Compiler_Command);

                     end if;

                  end;

               end if;

            end;

            Count := Count + 1;

            Name  := Language_Htable.Get_Next;

         end loop;

         return Result;

      end Get_Config_Switches;

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

      -- Do_Autoconf --

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

      procedure Do_Autoconf is

         Obj_Dir : constant Variable_Value :=

                     Value_Of

                       (Name_Object_Dir,

                        Project.Decl.Attributes,

                        Project_Tree);

         Gprconfig_Path  : String_Access;

         Success         : Boolean;

      begin

         Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);

         if Gprconfig_Path = null then

            raise Invalid_Config

              with "could not locate gprconfig for auto-configuration";

         end if;

         --  First, find the object directory of the user's project

         if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then

            Get_Name_String (Project.Directory.Name);

         else

            if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then

               Get_Name_String (Obj_Dir.Value);

            else

               Name_Len := 0;

               Add_Str_To_Name_Buffer

                 (Get_Name_String (Project.Directory.Name));

               Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));

            end if;

         end if;

         if Subdirs /= null then

            Add_Char_To_Name_Buffer (Directory_Separator);

            Add_Str_To_Name_Buffer (Subdirs.all);

         end if;

         for J in 1 .. Name_Len loop

            if Name_Buffer (J) = '/' then

               Name_Buffer (J) := Directory_Separator;

            end if;

         end loop;

         declare

            Obj_Dir  : constant String := Name_Buffer (1 .. Name_Len);

            Switches : Argument_List_Access := Get_Config_Switches;

            Args     : Argument_List (1 .. 5);

            Arg_Last : Positive;

            Obj_Dir_Exists : Boolean := True;

         begin

            --  Check if the object directory exists. If Setup_Projects is True

            --  (-p) and directory does not exist, attempt to create it.

            --  Otherwise, if directory does not exist, fail without calling

            --  gprconfig.

            if not Is_Directory (Obj_Dir)

              and then (Setup_Projects or else Subdirs /= null)

            then

               begin

                  Create_Path (Obj_Dir);

                  if not Quiet_Output then

                     Write_Str ("object directory """);

                     Write_Str (Obj_Dir);

                     Write_Line (""" created");

                  end if;

               exception

                  when others =>

                     raise Invalid_Config

                       with "could not create object directory " & Obj_Dir;

               end;

            end if;

            if not Is_Directory (Obj_Dir) then

               case Flags.Require_Obj_Dirs is

                  when Error =>

                     raise Invalid_Config

                       with "object directory " & Obj_Dir & " does not exist";

                  when Warning =>

                     Prj.Err.Error_Msg

                       (Flags,

                        "?object directory " & Obj_Dir & " does not exist");

                     Obj_Dir_Exists := False;

                  when Silent =>

                     null;

               end case;

            end if;

            --  Invoke gprconfig

            Args (1) := new String'("--batch");

            Args (2) := new String'("-o");

            --  If no config file was specified, set the auto.cgpr one

            if Config_File_Name = "" then

               if Obj_Dir_Exists then

                  Args (3) :=

                    new String'(Obj_Dir & Directory_Separator & Auto_Cgpr);

               else

                  declare

                     Path_FD   : File_Descriptor;

                     Path_Name : Path_Name_Type;

                  begin

                     Prj.Env.Create_Temp_File

                       (In_Tree   => Project_Tree,

                        Path_FD   => Path_FD,

                        Path_Name => Path_Name,

                        File_Use  => "configuration file");

                     if Path_FD /= Invalid_FD then

                        Args (3) := new String'(Get_Name_String (Path_Name));

                        GNAT.OS_Lib.Close (Path_FD);

                     else

                        --  We'll have an error message later on