------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . C O N F -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2014, 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 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 Ada.Directories; use Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.HTable; use GNAT.HTable; package body Prj.Conf is Auto_Cgpr : constant String := "auto.cgpr"; 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"; Warn_For_RTS : Boolean := True; -- Set to False when gprbuild parse again the project files, to avoid -- an incorrect warning. type Runtime_Root_Data; type Runtime_Root_Ptr is access Runtime_Root_Data; type Runtime_Root_Data is record Root : String_Access; Next : Runtime_Root_Ptr; end record; -- Data for a runtime root to be used when adding directories to the -- project path. type Compiler_Root_Data; type Compiler_Root_Ptr is access Compiler_Root_Data; type Compiler_Root_Data is record Root : String_Access; Runtimes : Runtime_Root_Ptr; Next : Compiler_Root_Ptr; end record; -- Data for a compiler root to be used when adding directories to the -- project path. First_Compiler_Root : Compiler_Root_Ptr := null; -- Head of the list of compiler roots 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. ----------------------- -- Local_Subprograms -- ----------------------- 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. 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. procedure Raise_Invalid_Config (Msg : String); pragma No_Return (Raise_Invalid_Config); -- Raises exception Invalid_Config with given message procedure Apply_Config_File (Config_File : Prj.Project_Id; Project_Tree : Prj.Project_Tree_Ref); -- Apply the configuration file settings to all the projects in the -- project tree. The Project_Tree must have been parsed first, and -- processed through the first phase so that all its projects are known. -- -- Currently, this will add new attributes and packages in the various -- projects, so that when the second phase of the processing is performed -- these attributes are automatically taken into account. type State is (No_State); procedure Look_For_Project_Paths (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out State); -- Check the compilers in the Project and add record them in the list -- rooted at First_Compiler_Root, with their runtimes, if they are not -- already in the list. procedure Update_Project_Path is new For_Every_Project_Imported (State => State, Action => Look_For_Project_Paths); ------------------------------------ -- Add_Default_GNAT_Naming_Scheme -- ------------------------------------ procedure Add_Default_GNAT_Naming_Scheme (Config_File : in out Project_Node_Id; Project_Tree : Project_Node_Tree_Ref) is procedure Create_Attribute (Name : Name_Id; Value : String; Index : String := ""; Pkg : Project_Node_Id := Empty_Node); ---------------------- -- Create_Attribute -- ---------------------- procedure Create_Attribute (Name : Name_Id; Value : String; Index : String := ""; Pkg : Project_Node_Id := Empty_Node) is Attr : Project_Node_Id; pragma Unreferenced (Attr); Expr : Name_Id := No_Name; Val : Name_Id := No_Name; Parent : Project_Node_Id := Config_File; begin if Index /= "" then Name_Len := Index'Length; Name_Buffer (1 .. Name_Len) := Index; Val := Name_Find; end if; if Pkg /= Empty_Node then Parent := Pkg; end if; Name_Len := Value'Length; Name_Buffer (1 .. Name_Len) := Value; Expr := Name_Find; Attr := Create_Attribute (Tree => Project_Tree, Prj_Or_Pkg => Parent, Name => Name, Index_Name => Val, Kind => Prj.Single, Value => Create_Literal_String (Expr, Project_Tree)); end Create_Attribute; -- Local variables Name : Name_Id; Naming : Project_Node_Id; Compiler : Project_Node_Id; -- Start of processing for Add_Default_GNAT_Naming_Scheme begin if Config_File = Empty_Node then -- Create a dummy config file if none was found Name_Len := Auto_Cgpr'Length; Name_Buffer (1 .. Name_Len) := Auto_Cgpr; Name := Name_Find; -- An invalid project name to avoid conflicts with user-created ones Name_Len := 5; Name_Buffer (1 .. Name_Len) := "_auto"; Config_File := Create_Project (In_Tree => Project_Tree, Name => Name_Find, Full_Path => Path_Name_Type (Name), Is_Config_File => True); -- Setup library support case MLib.Tgt.Support_For_Libraries is when None => null; when Static_Only => Create_Attribute (Name_Library_Support, "static_only"); when Full => Create_Attribute (Name_Library_Support, "full"); end case; if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then Create_Attribute (Name_Library_Auto_Init_Supported, "true"); else Create_Attribute (Name_Library_Auto_Init_Supported, "false"); end if; -- Declare an empty target Create_Attribute (Name_Target, ""); -- Setup Ada support (Ada is the default language here, since this -- is only called when no config file existed initially, ie for -- gnatmake). Create_Attribute (Name_Default_Language, "ada"); Compiler := Create_Package (Project_Tree, Config_File, "compiler"); Create_Attribute (Name_Driver, "gcc", "ada", Pkg => Compiler); Create_Attribute (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler); Create_Attribute (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler); Naming := Create_Package (Project_Tree, Config_File, "naming"); Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); if Current_Verbosity = High then Write_Line ("Automatically generated (in-memory) config file"); Prj.PP.Pretty_Print (Project => Config_File, In_Tree => Project_Tree, Backward_Compatibility => False); end if; end if; end Add_Default_GNAT_Naming_Scheme; ----------------------- -- Apply_Config_File -- ----------------------- procedure Apply_Config_File (Config_File : Prj.Project_Id; Project_Tree : Prj.Project_Tree_Ref) is 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. -------------------- -- Add_Attributes -- -------------------- procedure Add_Attributes (Project_Tree : Project_Tree_Ref; Conf_Decl : Declarations; User_Decl : in out Declarations) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; 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 := Shared.Variable_Elements.Table (Conf_Attr_Id); User_Attr := Shared.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; Shared.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 User_List : constant String_List_Id := User_Attr.Value.Values; Conf_List : String_List_Id := Conf_Attr.Value.Values; Conf_Elem : String_Element; New_List : String_List_Id; New_Elem : String_Element; begin -- Create new list String_Element_Table.Increment_Last (Shared.String_Elements); New_List := String_Element_Table.Last (Shared.String_Elements); -- Value of attribute is new list User_Attr.Value.Values := New_List; Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; loop -- Get each element of configuration list Conf_Elem := Shared.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; Shared.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 (Shared.String_Elements); New_Elem.Next := String_Element_Table.Last (Shared.String_Elements); Shared.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 := Shared.Arrays.Table (Conf_Array_Id); User_Array_Id := User_Decl.Arrays; while User_Array_Id /= No_Array loop User_Array := Shared.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 (Shared.Arrays); User_Array := Conf_Array; User_Array.Next := User_Decl.Arrays; User_Decl.Arrays := Array_Table.Last (Shared.Arrays); Shared.Arrays.Table (User_Decl.Arrays) := User_Array; -- Otherwise, check each array element else Conf_Array_Elem_Id := Conf_Array.Value; while Conf_Array_Elem_Id /= No_Array_Element loop Conf_Array_Elem := Shared.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 := Shared.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 doesn't 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 (Shared.Array_Elements); User_Array_Elem := Conf_Array_Elem; User_Array_Elem.Next := User_Array.Value; User_Array.Value := Array_Element_Table.Last (Shared.Array_Elements); Shared.Array_Elements.Table (User_Array.Value) := User_Array_Elem; Shared.Arrays.Table (User_Array_Id) := User_Array; -- Otherwise, if the value is a string list, prepend the -- conf array element value to the array element. 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 := Shared.String_Elements.Table (Conf_List); String_Element_Table.Increment_Last (Shared.String_Elements); Next := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Next) := Conf_List_Elem; if Previous = Nil_String then User_Array_Elem.Value.Values := Next; Shared.Array_Elements.Table (User_Array_Elem_Id) := User_Array_Elem; else Shared.String_Elements.Table (Previous).Next := Next; end if; Previous := Next; Conf_List := Conf_List_Elem.Next; if Conf_List = Nil_String then Shared.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; Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Conf_Decl : constant Declarations := Config_File.Decl; Conf_Pack_Id : Package_Id; Conf_Pack : Package_Element; User_Decl : Declarations; User_Pack_Id : Package_Id; User_Pack : Package_Element; Proj : Project_List; begin Debug_Output ("Applying config file to a project tree"); Proj := Project_Tree.Projects; while Proj /= null loop if Proj.Project /= Config_File then User_Decl := Proj.Project.Decl; Add_Attributes (Project_Tree => Project_Tree, Conf_Decl => Conf_Decl, User_Decl => User_Decl); Conf_Pack_Id := Conf_Decl.Packages; while Conf_Pack_Id /= No_Package loop Conf_Pack := Shared.Packages.Table (Conf_Pack_Id); User_Pack_Id := User_Decl.Packages; while User_Pack_Id /= No_Package loop User_Pack := Shared.Packages.Table (User_Pack_Id); exit when User_Pack.Name = Conf_Pack.Name; User_Pack_Id := User_Pack.Next; end loop; if User_Pack_Id = No_Package then Package_Table.Increment_Last (Shared.Packages); User_Pack := Conf_Pack; User_Pack.Next := User_Decl.Packages; User_Decl.Packages := Package_Table.Last (Shared.Packages); Shared.Packages.Table (User_Decl.Packages) := User_Pack; else Add_Attributes (Project_Tree => Project_Tree, Conf_Decl => Conf_Pack.Decl, User_Decl => Shared.Packages.Table (User_Pack_Id).Decl); end if; Conf_Pack_Id := Conf_Pack.Next; end loop; Proj.Project.Decl := User_Decl; -- For aggregate projects, we need to apply the config to all -- their aggregated trees as well. if Proj.Project.Qualifier in Aggregate_Project then declare List : Aggregated_Project_List; begin List := Proj.Project.Aggregated_Projects; while List /= null loop Debug_Output ("Recursively apply config to aggregated tree", List.Project.Name); Apply_Config_File (Config_File, Project_Tree => List.Tree); List := List.Next; end loop; end; end if; end if; Proj := Proj.Next; end loop; end Apply_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 Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Variable : constant Variable_Value := Value_Of (Name_Target, Config_File.Decl.Attributes, Shared); 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; OK := Target = "" or else (Tgt_Name /= No_Name and then (Length_Of_Name (Tgt_Name) = 0 or else Target = Get_Name_String (Tgt_Name))); 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 ("mismatched targets: """ & Get_Name_String (Tgt_Name) & """ in configuration, """ & Target & """ specified"); else Raise_Invalid_Config ("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; Conf_Project : Project_Id; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; 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; On_Load_Config : Config_File_Hook := null) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; At_Least_One_Compiler_Command : Boolean := False; -- Set to True if at least one attribute Ide'Compiler_Command is -- specified for one language of the system. Conf_File_Name : String_Access := new String'(Config_File_Name); -- The configuration project file name. May be modified if there are -- switches --config= in the Builder package of the main project. Selected_Target : String_Access := new String'(Target_Name); 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 procedure Check_Builder_Switches; -- Check for switches --config and --RTS in package Builder procedure Get_Project_Target; -- If Target_Name is empty, get the specified target in the project -- file, if any. procedure Get_Project_Runtimes; -- Get the various Runtime () in the project file or any project -- it extends, if any are specified. function Get_Config_Switches return Argument_List_Access; -- Return the --config switches to use for gprconfig function Get_Db_Switches return Argument_List_Access; -- Return the --db 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. ---------------------------- -- Check_Builder_Switches -- ---------------------------- procedure Check_Builder_Switches is Get_RTS_Switches : constant Boolean := RTS_Languages.Get_First = No_Name; -- If no switch --RTS have been specified on the command line, look -- for --RTS switches in the Builder switches. Builder : constant Package_Id := Value_Of (Name_Builder, Project.Decl.Packages, Shared); Switch_Array_Id : Array_Element_Id; -- The Switches to be checked procedure Check_Switches; -- Check the switches in Switch_Array_Id -------------------- -- Check_Switches -- -------------------- procedure Check_Switches is Switch_Array : Array_Element; Switch_List : String_List_Id := Nil_String; Switch : String_Element; Lang : Name_Id; Lang_Last : Positive; begin while Switch_Array_Id /= No_Array_Element loop Switch_Array := Shared.Array_Elements.Table (Switch_Array_Id); Switch_List := Switch_Array.Value.Values; List_Loop : while Switch_List /= Nil_String loop Switch := Shared.String_Elements.Table (Switch_List); if Switch.Value /= No_Name then Get_Name_String (Switch.Value); if Conf_File_Name'Length = 0 and then Name_Len > 9 and then Name_Buffer (1 .. 9) = "--config=" then Conf_File_Name := new String'(Name_Buffer (10 .. Name_Len)); elsif Get_RTS_Switches and then Name_Len >= 7 and then Name_Buffer (1 .. 5) = "--RTS" then if Name_Buffer (6) = '=' then if not Runtime_Name_Set_For (Name_Ada) then Set_Runtime_For (Name_Ada, Name_Buffer (7 .. Name_Len)); end if; elsif Name_Len > 7 and then Name_Buffer (6) = ':' and then Name_Buffer (7) /= '=' then Lang_Last := 7; while Lang_Last < Name_Len and then Name_Buffer (Lang_Last + 1) /= '=' loop Lang_Last := Lang_Last + 1; end loop; if Name_Buffer (Lang_Last + 1) = '=' then declare RTS : constant String := Name_Buffer (Lang_Last + 2 .. Name_Len); begin Name_Buffer (1 .. Lang_Last - 6) := Name_Buffer (7 .. Lang_Last); Name_Len := Lang_Last - 6; To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; if not Runtime_Name_Set_For (Lang) then Set_Runtime_For (Lang, RTS); end if; end; end if; end if; end if; end if; Switch_List := Switch.Next; end loop List_Loop; Switch_Array_Id := Switch_Array.Next; end loop; end Check_Switches; -- Start of processing for Check_Builder_Switches begin if Builder /= No_Package then Switch_Array_Id := Value_Of (Name => Name_Switches, In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, Shared => Shared); Check_Switches; Switch_Array_Id := Value_Of (Name => Name_Default_Switches, In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, Shared => Shared); Check_Switches; end if; end Check_Builder_Switches; ------------------------ -- Get_Project_Target -- ------------------------ procedure Get_Project_Target is begin if Selected_Target'Length = 0 then -- Check if attribute Target is specified in the main -- project, or in a project it extends. If it is, use this -- target to invoke gprconfig. declare Variable : Variable_Value; Proj : Project_Id; Tgt_Name : Name_Id := No_Name; begin Proj := Project; Project_Loop : while Proj /= No_Project loop Variable := Value_Of (Name_Target, Proj.Decl.Attributes, Shared); if Variable /= Nil_Variable_Value and then not Variable.Default and then Variable.Value /= No_Name then Tgt_Name := Variable.Value; exit Project_Loop; end if; Proj := Proj.Extends; end loop Project_Loop; if Tgt_Name /= No_Name then Selected_Target := new String'(Get_Name_String (Tgt_Name)); end if; end; end if; end Get_Project_Target; -------------------------- -- Get_Project_Runtimes -- -------------------------- procedure Get_Project_Runtimes is Element : Array_Element; Id : Array_Element_Id; Lang : Name_Id; Proj : Project_Id; begin Proj := Project; while Proj /= No_Project loop Id := Value_Of (Name_Runtime, Proj.Decl.Arrays, Shared); while Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Id); Lang := Element.Index; if not Runtime_Name_Set_For (Lang) then Set_Runtime_For (Lang, RTS_Name => Get_Name_String (Element.Value.Value)); end if; Id := Element.Next; end loop; Proj := Proj.Extends; end loop; end Get_Project_Runtimes; ----------------------- -- Default_File_Name -- ----------------------- function Default_File_Name return String is Ada_RTS : constant String := Runtime_Name_For (Name_Ada); Tmp : String_Access; begin if Selected_Target'Length /= 0 then if Ada_RTS /= "" then return Selected_Target.all & '-' & Ada_RTS & Config_Project_File_Extension; else return Selected_Target.all & 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_Config_Name; else return T; end if; end; end if; end Default_File_Name; ----------------- -- Do_Autoconf -- ----------------- procedure Do_Autoconf is Obj_Dir : constant Variable_Value := Value_Of (Name_Object_Dir, Conf_Project.Decl.Attributes, Shared); Gprconfig_Path : String_Access; Success : Boolean; begin Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); if Gprconfig_Path = null then Raise_Invalid_Config ("could not locate gprconfig for auto-configuration"); end if; -- First, find the object directory of the Conf_Project if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then Get_Name_String (Conf_Project.Directory.Display_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 (Conf_Project.Directory.Display_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; -- Make sure that Obj_Dir ends with a directory separator if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Directory_Separator; end if; declare Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); Config_Switches : Argument_List_Access; Db_Switches : Argument_List_Access; 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 ("could not create object directory " & Obj_Dir); end; end if; if not Is_Directory (Obj_Dir) then case Env.Flags.Require_Obj_Dirs is when Error => Raise_Invalid_Config ("object directory " & Obj_Dir & " does not exist"); when Warning => Prj.Err.Error_Msg (Env.Flags, "?object directory " & Obj_Dir & " does not exist"); Obj_Dir_Exists := False; when Silent => null; end case; end if; -- Get the config switches. This should be done only now, as some -- runtimes may have been found in the Builder switches. Config_Switches := Get_Config_Switches; -- Get eventual --db switches Db_Switches := Get_Db_Switches; -- Invoke gprconfig Args (1) := new String'("--batch"); Args (2) := new String'("-o"); -- If no config file was specified, set the auto.cgpr one if Conf_File_Name'Length = 0 then if Obj_Dir_Exists then Args (3) := new String'(Obj_Dir & Auto_Cgpr); else declare Path_FD : File_Descriptor; Path_Name : Path_Name_Type; begin Prj.Env.Create_Temp_File (Shared => Project_Tree.Shared, Path_FD => Path_FD, Path_Name => Path_Name, File_Use => "configuration file"); if Path_FD /= Invalid_FD then declare Temp_Dir : constant String := Containing_Directory (Get_Name_String (Path_Name)); begin GNAT.OS_Lib.Close (Path_FD); Args (3) := new String'(Temp_Dir & Directory_Separator & Auto_Cgpr); Delete_File (Get_Name_String (Path_Name)); end; else -- We'll have an error message later on Args (3) := new String'(Obj_Dir & Auto_Cgpr); end if; end; end if; else Args (3) := Conf_File_Name; end if; Arg_Last := 3; if Selected_Target /= null and then Selected_Target.all /= "" then Args (4) := new String'("--target=" & Selected_Target.all); Arg_Last := 4; elsif Normalized_Hostname /= "" then if At_Least_One_Compiler_Command then Args (4) := new String'("--target=all"); else Args (4) := new String'("--target=" & Normalized_Hostname); end if; Arg_Last := 4; end if; if not Verbose_Mode then Arg_Last := Arg_Last + 1; Args (Arg_Last) := new String'("-q"); end if; if Verbose_Mode then Write_Str (Gprconfig_Name); for J in 1 .. Arg_Last loop Write_Char (' '); Write_Str (Args (J).all); end loop; for J in Config_Switches'Range loop Write_Char (' '); Write_Str (Config_Switches (J).all); end loop; for J in Db_Switches'Range loop Write_Char (' '); Write_Str (Db_Switches (J).all); end loop; Write_Eol; elsif not Quiet_Output then -- Display no message if we are creating auto.cgpr, unless in -- verbose mode. if Config_File_Name'Length > 0 or else Verbose_Mode then Write_Str ("creating "); Write_Str (Simple_Name (Args (3).all)); Write_Eol; end if; end if; Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Config_Switches.all & Db_Switches.all, Success); Free (Config_Switches); Config_File_Path := Locate_Config_File (Args (3).all); if Config_File_Path = null then Raise_Invalid_Config ("could not create " & Args (3).all); end if; for F in Args'Range loop Free (Args (F)); end loop; end; end Do_Autoconf; --------------------- -- Get_Db_Switches -- --------------------- function Get_Db_Switches return Argument_List_Access is Result : Argument_List_Access; Nmb_Arg : Natural; begin Nmb_Arg := (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base); Result := new Argument_List (1 .. Nmb_Arg); if Nmb_Arg /= 0 then for J in 1 .. Db_Switch_Args.Last loop Result (2 * J - 1) := new String'("--db"); Result (2 * J) := new String'(Get_Name_String (Db_Switch_Args.Table (J))); end loop; if not Load_Standard_Base then Result (Result'Last) := new String'("--db-"); end if; end if; return Result; end Get_Db_Switches; ------------------------- -- 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, Shared); procedure Add_Config_Switches_For_Project (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Integer); -- Add all --config switches for this project. This is also called -- for aggregate projects. ------------------------------------- -- Add_Config_Switches_For_Project -- ------------------------------------- procedure Add_Config_Switches_For_Project (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Integer) is pragma Unreferenced (With_State); Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; Variable : Variable_Value; Check_Default : Boolean; Lang : Name_Id; List : String_List_Id; Elem : String_Element; begin if Might_Have_Sources (Project) then Variable := Value_Of (Name_Languages, Project.Decl.Attributes, Shared); 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 := Project.Extends = No_Project; if not Check_Default then Variable := Value_Of (Name_Languages, Project.Extends.Decl.Attributes, Shared); Check_Default := Variable /= Nil_Variable_Value and then Variable.Values = Nil_String; end if; if Check_Default then Variable := Value_Of (Name_Default_Language, Project.Decl.Attributes, Shared); 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); -- If no default language is declared, default to Ada else 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 := Shared.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; end Add_Config_Switches_For_Project; procedure For_Every_Imported_Project is new For_Every_Project_Imported (State => Integer, Action => Add_Config_Switches_For_Project); -- Document this procedure ??? -- Local variables Name : Name_Id; Count : Natural; Result : Argument_List_Access; Variable : Variable_Value; Dummy : Integer := 0; -- Start of processing for Get_Config_Switches begin For_Every_Imported_Project (By => Project, Tree => Project_Tree, With_State => Dummy, Include_Aggregated => True); 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, Shared => Shared, Force_Lower_Case_Index => True); declare Config_Command : constant String := "--config=" & Get_Name_String (Name); Runtime_Name : constant String := Runtime_Name_For (Name); begin -- In CodePeer mode, we do not take into account any compiler -- command from the package IDE. if CodePeer_Mode or else Variable = Nil_Variable_Value or else Length_Of_Name (Variable.Value) = 0 then Result (Count) := new String'(Config_Command & ",," & Runtime_Name); else At_Least_One_Compiler_Command := True; 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; ------------------------ -- 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, Shared); 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, Shared); return Variable = Nil_Variable_Value or else Variable.Default or else Variable.Values /= Nil_String; else return False; end if; end Might_Have_Sources; -- Local Variables Success : Boolean; Config_Project_Node : Project_Node_Id := Empty_Node; -- Start of processing for Get_Or_Create_Configuration_File begin pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); Free (Config_File_Path); Config := No_Project; Get_Project_Target; Get_Project_Runtimes; Check_Builder_Switches; -- Do not attempt to find a configuration project file when -- Config_File_Name is No_Configuration_File. if Config_File_Name = No_Configuration_File then Config_File_Path := null; else if Conf_File_Name'Length > 0 then Config_File_Path := Locate_Config_File (Conf_File_Name.all); else Config_File_Path := Locate_Config_File (Default_File_Name); end if; if Config_File_Path = null then if not Allow_Automatic_Generation and then Conf_File_Name'Length > 0 then Raise_Invalid_Config ("could not locate main configuration project " & Conf_File_Name.all); end if; end if; end if; Automatically_Generated := Allow_Automatic_Generation and then Config_File_Path = null; <> if Automatically_Generated then -- This might raise an Invalid_Config exception Do_Autoconf; -- If the config file is not auto-generated, warn if there is any --RTS -- switch, but not when the config file is generated in memory. elsif Warn_For_RTS and then RTS_Languages.Get_First /= No_Name and then Opt.Warning_Mode /= Opt.Suppress and then On_Load_Config = null then Write_Line ("warning: " & "runtimes are taken into account only in auto-configuration"); end if; -- Parse the configuration file if Verbose_Mode and then Config_File_Path /= null then Write_Str ("Checking configuration "); Write_Line (Config_File_Path.all); end if; if Config_File_Path /= null then Prj.Part.Parse (In_Tree => Project_Node_Tree, Project => Config_Project_Node, Project_File_Name => Config_File_Path.all, Errout_Handling => Prj.Part.Finalize_If_Error, Packages_To_Check => Packages_To_Check, Current_Directory => Current_Directory, Is_Config_File => True, Env => Env); else Config_Project_Node := Empty_Node; end if; if On_Load_Config /= null then On_Load_Config (Config_File => Config_Project_Node, Project_Node_Tree => Project_Node_Tree); end if; if Config_Project_Node /= Empty_Node then Prj.Proc.Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Config, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => Config_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => False, On_New_Tree_Loaded => null); end if; if Config_Project_Node = Empty_Node or else Config = No_Project then Raise_Invalid_Config ("processing of configuration project """ & Config_File_Path.all & """ failed"); end if; -- Check that the target of the configuration file is the one the user -- specified on the command line. We do not need to check that when in -- auto-conf mode, since the appropriate target was passed to gprconfig. if not Automatically_Generated and then not Check_Target (Config, Autoconf_Specified, Project_Tree, Selected_Target.all) then Automatically_Generated := True; goto Process_Config_File; end if; end Get_Or_Create_Configuration_File; ------------------------ -- 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; ------------------------------------ -- Parse_Project_And_Apply_Config -- ------------------------------------ procedure Parse_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; User_Project_Node : out Prj.Tree.Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_File_Name : String; Project_Tree : Prj.Project_Tree_Ref; Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Implicit_Project : Boolean := False; On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null) is Success : Boolean := False; Target_Try_Again : Boolean := True; Config_Try_Again : Boolean; Finalization : Prj.Part.Errout_Mode := Prj.Part.Always_Finalize; S : State := No_State; Conf_File_Name : String_Access := new String'(Config_File_Name); procedure Add_Directory (Dir : String); -- Add a directory at the end of the Project Path Auto_Generated : Boolean; ------------------- -- Add_Directory -- ------------------- procedure Add_Directory (Dir : String) is begin if Opt.Verbose_Mode then Write_Line (" Adding directory """ & Dir & """"); end if; Prj.Env.Add_Directories (Env.Project_Path, Dir); end Add_Directory; begin pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); -- Start with ignoring missing withed projects Set_Ignore_Missing_With (Env.Flags, True); -- Note: If in fact the config file is automatically generated, then -- Automatically_Generated will be set to True after invocation of -- Process_Project_And_Apply_Config. Automatically_Generated := False; -- Record Target_Value and Target_Origin if Target_Name = "" then Opt.Target_Value := new String'(Normalized_Hostname); Opt.Target_Origin := Default; else Opt.Target_Value := new String'(Target_Name); Opt.Target_Origin := Specified; end if; <> -- Parse the user project tree Project_Node_Tree.Incomplete_With := False; Env.Flags.Incomplete_Withs := False; Prj.Initialize (Project_Tree); Main_Project := No_Project; Prj.Part.Parse (In_Tree => Project_Node_Tree, Project => User_Project_Node, Project_File_Name => Project_File_Name, Errout_Handling => Finalization, Packages_To_Check => Packages_To_Check, Current_Directory => Current_Directory, Is_Config_File => False, Env => Env, Implicit_Project => Implicit_Project); Finalization := Prj.Part.Finalize_If_Error; if User_Project_Node = Empty_Node then return; end if; -- If --target was not specified on the command line, then do Phase 1 to -- check if attribute Target is declared in the main project. if Opt.Target_Origin /= Specified then Main_Project := No_Project; Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Main_Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => True, On_New_Tree_Loaded => On_New_Tree_Loaded); if not Success then Main_Project := No_Project; return; end if; declare Variable : constant Variable_Value := Value_Of (Name_Target, Main_Project.Decl.Attributes, Project_Tree.Shared); begin if Variable /= Nil_Variable_Value and then not Variable.Default and then Get_Name_String (Variable.Value) /= Opt.Target_Value.all then if Target_Try_Again then Opt.Target_Value := new String'(Get_Name_String (Variable.Value)); Target_Try_Again := False; goto Parse_Again; else Fail_Program (Project_Tree, "inconsistent value of attribute Target"); end if; end if; end; end if; -- If there are missing withed projects, the projects will be parsed -- again after the project path is extended with directories rooted -- at the compiler roots. Config_Try_Again := Project_Node_Tree.Incomplete_With; Process_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Conf_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Env => Env, Packages_To_Check => Packages_To_Check, Allow_Automatic_Generation => Allow_Automatic_Generation, Automatically_Generated => Auto_Generated, Config_File_Path => Config_File_Path, Target_Name => Target_Name, Normalized_Hostname => Normalized_Hostname, On_Load_Config => On_Load_Config, On_New_Tree_Loaded => On_New_Tree_Loaded, Do_Phase_1 => Opt.Target_Origin = Specified); if Auto_Generated then Automatically_Generated := True; end if; -- Exit if there was an error. Otherwise, if Config_Try_Again is True, -- update the project path and try again. if Main_Project /= No_Project and then Config_Try_Again then Set_Ignore_Missing_With (Env.Flags, False); if Config_File_Path /= null then Conf_File_Name := new String'(Config_File_Path.all); end if; -- For the second time the project files are parsed, the warning for -- --RTS= being only taken into account in auto-configuration are -- suppressed, as we are no longer in auto-configuration. Warn_For_RTS := False; -- Add the default directories corresponding to the compilers Update_Project_Path (By => Main_Project, Tree => Project_Tree, With_State => S, Include_Aggregated => True, Imported_First => False); declare Compiler_Root : Compiler_Root_Ptr; Prefix : String_Access; Runtime_Root : Runtime_Root_Ptr; Path_Value : constant String_Access := Getenv ("PATH"); begin if Opt.Verbose_Mode then Write_Line ("Setting the default project search directories"); if Prj.Current_Verbosity = High then if Path_Value = null or else Path_Value'Length = 0 then Write_Line ("No environment variable PATH"); else Write_Line ("PATH ="); Write_Line (" " & Path_Value.all); end if; end if; end if; -- Reorder the compiler roots in the PATH order if First_Compiler_Root /= null and then First_Compiler_Root.Next /= null then declare Pred : Compiler_Root_Ptr; First_New_Comp : Compiler_Root_Ptr := null; New_Comp : Compiler_Root_Ptr := null; First : Positive := Path_Value'First; Last : Positive; Path_Last : Positive; begin while First <= Path_Value'Last loop Last := First; if Path_Value (First) /= Path_Separator then while Last < Path_Value'Last and then Path_Value (Last + 1) /= Path_Separator loop Last := Last + 1; end loop; Path_Last := Last; while Path_Last > First and then Path_Value (Path_Last) = Directory_Separator loop Path_Last := Path_Last - 1; end loop; if Path_Last > First + 4 and then Path_Value (Path_Last - 2 .. Path_Last) = "bin" and then Path_Value (Path_Last - 3) = Directory_Separator then Path_Last := Path_Last - 4; Pred := null; Compiler_Root := First_Compiler_Root; while Compiler_Root /= null and then Compiler_Root.Root.all /= Path_Value (First .. Path_Last) loop Pred := Compiler_Root; Compiler_Root := Compiler_Root.Next; end loop; if Compiler_Root /= null then if Pred = null then First_Compiler_Root := First_Compiler_Root.Next; else Pred.Next := Compiler_Root.Next; end if; if First_New_Comp = null then First_New_Comp := Compiler_Root; else New_Comp.Next := Compiler_Root; end if; New_Comp := Compiler_Root; New_Comp.Next := null; end if; end if; end if; First := Last + 1; end loop; if First_New_Comp /= null then New_Comp.Next := First_Compiler_Root; First_Compiler_Root := First_New_Comp; end if; end; end if; -- Now that the compiler roots are in a correct order, add the -- directories corresponding to these compiler roots in the -- project path. Compiler_Root := First_Compiler_Root; while Compiler_Root /= null loop Prefix := Compiler_Root.Root; Runtime_Root := Compiler_Root.Runtimes; while Runtime_Root /= null loop Add_Directory (Runtime_Root.Root.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); Add_Directory (Runtime_Root.Root.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Runtime_Root := Runtime_Root.Next; end loop; Add_Directory (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); Add_Directory (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Prefix.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Prefix.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); Compiler_Root := Compiler_Root.Next; end loop; end; -- And parse again the project files. There will be no missing -- withed projects, as Ignore_Missing_With is set to False in -- the environment flags, so there is no risk of endless loop here. goto Parse_Again; end if; end Parse_Project_And_Apply_Config; -------------------------------------- -- Process_Project_And_Apply_Config -- -------------------------------------- procedure Process_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; User_Project_Node : Prj.Tree.Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_Tree : Prj.Project_Tree_Ref; Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; Env : in out Prj.Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null; Do_Phase_1 : Boolean := True) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Main_Config_Project : Project_Id; Success : Boolean; Conf_Project : Project_Id := No_Project; -- The object directory of this project is used to store the config -- project file in auto-configuration. Set by Check_Project below. procedure Check_Project (Project : Project_Id); -- Look for a non aggregate project. If one is found, put its project Id -- in Conf_Project. ------------------- -- Check_Project -- ------------------- procedure Check_Project (Project : Project_Id) is begin if Project.Qualifier = Aggregate or else Project.Qualifier = Aggregate_Library then declare List : Aggregated_Project_List := Project.Aggregated_Projects; begin -- Look for a non aggregate project until one is found while Conf_Project = No_Project and then List /= null loop Check_Project (List.Project); List := List.Next; end loop; end; else Conf_Project := Project; end if; end Check_Project; -- Start of processing for Process_Project_And_Apply_Config begin Automatically_Generated := False; if Do_Phase_1 then Main_Project := No_Project; Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Main_Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => Reset_Tree, On_New_Tree_Loaded => On_New_Tree_Loaded); if not Success then Main_Project := No_Project; return; end if; end if; if Project_Tree.Source_Info_File_Name /= null then if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then declare Obj_Dir : constant Variable_Value := Value_Of (Name_Object_Dir, Main_Project.Decl.Attributes, Shared); begin if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then Get_Name_String (Main_Project.Directory.Display_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 (Main_Project.Directory.Display_Name)); Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); end if; end if; Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all); Free (Project_Tree.Source_Info_File_Name); Project_Tree.Source_Info_File_Name := new String'(Name_Buffer (1 .. Name_Len)); end; end if; Read_Source_Info_File (Project_Tree); end if; -- Get the first project that is not an aggregate project or an -- aggregate library project. The object directory of this project will -- be used to store the config project file in auto-configuration. Check_Project (Main_Project); -- Fail if there is only aggregate projects and aggregate library -- projects in the project tree. if Conf_Project = No_Project then Raise_Invalid_Config ("there are no non-aggregate projects"); end if; -- Find configuration file Get_Or_Create_Configuration_File (Config => Main_Config_Project, Project => Main_Project, Conf_Project => Conf_Project, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Env => Env, Allow_Automatic_Generation => Allow_Automatic_Generation, Config_File_Name => Config_File_Name, Autoconf_Specified => Autoconf_Specified, Target_Name => Target_Name, Normalized_Hostname => Normalized_Hostname, Packages_To_Check => Packages_To_Check, Config_File_Path => Config_File_Path, Automatically_Generated => Automatically_Generated, On_Load_Config => On_Load_Config); Apply_Config_File (Main_Config_Project, Project_Tree); -- Finish processing the user's project Prj.Proc.Process_Project_Tree_Phase_2 (In_Tree => Project_Tree, Project => Main_Project, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env); if Success then if Project_Tree.Source_Info_File_Name /= null and then not Project_Tree.Source_Info_File_Exists then Write_Source_Info_File (Project_Tree); end if; else Main_Project := No_Project; end if; end Process_Project_And_Apply_Config; -------------------------- -- Raise_Invalid_Config -- -------------------------- procedure Raise_Invalid_Config (Msg : String) is begin Raise_Exception (Invalid_Config'Identity, Msg); end Raise_Invalid_Config; ---------------------- -- Runtime_Name_For -- ---------------------- function Runtime_Name_For (Language : Name_Id) return String is begin if RTS_Languages.Get (Language) /= No_Name then return Get_Name_String (RTS_Languages.Get (Language)); else return ""; end if; end Runtime_Name_For; -------------------------- -- Runtime_Name_Set_For -- -------------------------- function Runtime_Name_Set_For (Language : Name_Id) return Boolean is begin return RTS_Languages.Get (Language) /= No_Name; end Runtime_Name_Set_For; --------------------- -- Set_Runtime_For -- --------------------- procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is begin Name_Len := RTS_Name'Length; Name_Buffer (1 .. Name_Len) := RTS_Name; RTS_Languages.Set (Language, Name_Find); end Set_Runtime_For; ---------------------------- -- Look_For_Project_Paths -- ---------------------------- procedure Look_For_Project_Paths (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out State) is Lang_Id : Language_Ptr; Compiler_Root : Compiler_Root_Ptr; Runtime_Root : Runtime_Root_Ptr; Comp_Driver : String_Access; Comp_Dir : String_Access; Prefix : String_Access; pragma Unreferenced (Tree); begin With_State := No_State; Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop if Lang_Id.Config.Compiler_Driver /= No_File then Comp_Driver := new String' (Get_Name_String (Lang_Id.Config.Compiler_Driver)); -- Get the absolute path of the compiler driver if not Is_Absolute_Path (Comp_Driver.all) then Comp_Driver := Locate_Exec_On_Path (Comp_Driver.all); end if; if Comp_Driver /= null and then Comp_Driver'Length > 0 then Comp_Dir := new String' (Containing_Directory (Comp_Driver.all)); -- Consider only the compiler drivers that are in "bin" -- subdirectories. if Simple_Name (Comp_Dir.all) = "bin" then Prefix := new String'(Containing_Directory (Comp_Dir.all)); -- Check if the compiler root is already in the list. If it -- is not, add it to the list. Compiler_Root := First_Compiler_Root; while Compiler_Root /= null loop exit when Prefix.all = Compiler_Root.Root.all; Compiler_Root := Compiler_Root.Next; end loop; if Compiler_Root = null then First_Compiler_Root := new Compiler_Root_Data' (Root => Prefix, Runtimes => null, Next => First_Compiler_Root); Compiler_Root := First_Compiler_Root; end if; -- If there is a runtime for this compiler, check if it is -- recorded with the compiler root. If it is not, record -- the runtime. declare Runtime : constant String := Runtime_Name_For (Lang_Id.Name); Root : String_Access; begin if Runtime'Length > 0 then if Is_Absolute_Path (Runtime) then Root := new String'(Runtime); else Root := new String' (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & Runtime); end if; Runtime_Root := Compiler_Root.Runtimes; while Runtime_Root /= null loop exit when Root.all = Runtime_Root.Root.all; Runtime_Root := Runtime_Root.Next; end loop; if Runtime_Root = null then Compiler_Root.Runtimes := new Runtime_Root_Data' (Root => Root, Next => Compiler_Root.Runtimes); end if; end if; end; end if; end if; end if; Lang_Id := Lang_Id.Next; end loop; end Look_For_Project_Paths; end Prj.Conf;