aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.7/gcc/ada/prj-conf.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.7/gcc/ada/prj-conf.adb')
-rw-r--r--gcc-4.7/gcc/ada/prj-conf.adb1611
1 files changed, 0 insertions, 1611 deletions
diff --git a/gcc-4.7/gcc/ada/prj-conf.adb b/gcc-4.7/gcc/ada/prj-conf.adb
deleted file mode 100644
index b0ea74100..000000000
--- a/gcc-4.7/gcc/ada/prj-conf.adb
+++ /dev/null
@@ -1,1611 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . C O N F --
--- --
--- B o d y --
--- --
--- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. 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);
-
- -- 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
- 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
- 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) := 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,
- 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);
- 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,
- 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);
-
- 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;