blob: 1514107effbf6e9d709591461cdd61553ff878ab [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P R J . C O N F --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006-2011, 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 Hostparm;
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";
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.
-----------------------
-- Local_Subprograms --
-----------------------
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 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.
--------------------
-- 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;
------------------------------------
-- 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 is 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;
-- 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
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;
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
("invalid target name """
& Get_Name_String (Tgt_Name) & """ in configuration");
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;
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.
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,
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;
-------------------------
-- 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);
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 := 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
if 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;
-----------------
-- Do_Autoconf --
-----------------
procedure Do_Autoconf is
Obj_Dir : constant Variable_Value :=
Value_Of
(Name_Object_Dir,
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 user's project
if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
Get_Name_String (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 (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;
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;
-- If no switch --RTS have been specified on the command line,
-- look for --RTS switches in the Builder switches.
if RTS_Languages.Get_First = No_Name then
declare
Builder : constant Package_Id :=
Value_Of
(Name_Builder, Project.Decl.Packages, Shared);
Switch_Array_Id : Array_Element_Id;
procedure Check_RTS_Switches;
-- Take into account eventual switches --RTS in
-- Switch_Array_Id.
------------------------
-- Check_RTS_SWitches --
------------------------
procedure Check_RTS_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;
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 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;
Switch_Array_Id := Switch_Array.Next;
end loop;
end Check_RTS_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_RTS_Switches;
Switch_Array_Id :=
Value_Of
(Name => Name_Default_Switches,
In_Arrays =>
Shared.Packages.Table (Builder).Decl.Arrays,
Shared => Shared);
Check_RTS_Switches;
end if;
end;
end if;
-- Get the config switches. This should be done only now, as some
-- runtimes may have been found if the Builder switches.
Config_Switches := Get_Config_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 Config_File_Name = "" 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
Args (3) := new String'(Get_Name_String (Path_Name));
GNAT.OS_Lib.Close (Path_FD);
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) := new String'(Config_File_Name);
end if;
if Normalized_Hostname = "" then
Arg_Last := 3;
else
if Target_Name = "" then
if At_Least_One_Compiler_Command then
Args (4) := new String'("--target=all");
else
Args (4) :=
new String'("--target=" & Normalized_Hostname);
end if;
else
Args (4) := new String'("--target=" & Target_Name);
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;
Write_Eol;
elsif not Quiet_Output then
-- Display no message if we are creating auto.cgpr, unless in
-- verbose mode
if Config_File_Name /= ""
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,
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;
Success : Boolean;
Config_Project_Node : Project_Node_Id := Empty_Node;
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
Free (Config_File_Path);
Config := No_Project;
if Config_File_Name /= "" then
Config_File_Path := Locate_Config_File (Config_File_Name);
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 Config_File_Name /= ""
then
Raise_Invalid_Config
("could not locate main configuration project "
& Config_File_Name);
end if;
end if;
Automatically_Generated :=
Allow_Automatic_Generation and then Config_File_Path = null;
<<Process_Config_File>>
if Automatically_Generated then
if Hostparm.OpenVMS then
-- There is no gprconfig on VMS
Raise_Invalid_Config
("could not locate any configuration project file");
else
-- This might raise an Invalid_Config exception
Do_Autoconf;
end if;
-- If the config file is not auto-generated, warn if there is any --RTS
-- switch on the command line.
elsif RTS_Languages.Get_First /= No_Name
and then Opt.Warning_Mode /= Opt.Suppress
then
Write_Line
("warning: --RTS is 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 On_Load_Config /= null then
On_Load_Config
(Config_File => Config_Project_Node,
Project_Node_Tree => Project_Node_Tree);
elsif 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 Config_Project_Node /= Empty_Node then
Prj.Proc.Process_Project_Tree_Phase_1
(In_Tree => Project_Tree,
Project => Config,
Success => Success,
From_Project_Node => Config_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Env => Env,
Reset_Tree => False);
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, Target_Name)
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)
is
begin
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
-- Parse the user project tree
Prj.Initialize (Project_Tree);
Main_Project := No_Project;
Automatically_Generated := False;
Prj.Part.Parse
(In_Tree => Project_Node_Tree,
Project => User_Project_Node,
Project_File_Name => Project_File_Name,
Errout_Handling => Prj.Part.Finalize_If_Error,
Packages_To_Check => Packages_To_Check,
Current_Directory => Current_Directory,
Is_Config_File => False,
Env => Env);
if User_Project_Node = Empty_Node then
User_Project_Node := Empty_Node;
return;
end if;
Process_Project_And_Apply_Config
(Main_Project => Main_Project,
User_Project_Node => User_Project_Node,
Config_File_Name => Config_File_Name,
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 => Automatically_Generated,
Config_File_Path => Config_File_Path,
Target_Name => Target_Name,
Normalized_Hostname => Normalized_Hostname,
On_Load_Config => On_Load_Config);
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)
is
Shared : constant Shared_Project_Tree_Data_Access :=
Project_Tree.Shared;
Main_Config_Project : Project_Id;
Success : Boolean;
begin
Main_Project := No_Project;
Automatically_Generated := False;
Process_Project_Tree_Phase_1
(In_Tree => Project_Tree,
Project => Main_Project,
Success => Success,
From_Project_Node => User_Project_Node,
From_Project_Node_Tree => Project_Node_Tree,
Env => Env,
Reset_Tree => Reset_Tree);
if not Success then
Main_Project := No_Project;
return;
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;
-- Find configuration file
Get_Or_Create_Configuration_File
(Config => Main_Config_Project,
Project => Main_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;
end Prj.Conf;