diff options
author | Emmanuel Briot <briot@adacore.com> | 2009-06-23 09:30:59 +0000 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-06-23 11:30:59 +0200 |
commit | abe19d88066a6afdaf8c6917a631d21e30e4091c (patch) | |
tree | e3a126bf326b9b39704593163279da9adcebd89e | |
parent | af268547dec49c0356f622369582fe2e2d112586 (diff) | |
download | gcc-abe19d88066a6afdaf8c6917a631d21e30e4091c.zip gcc-abe19d88066a6afdaf8c6917a631d21e30e4091c.tar.gz gcc-abe19d88066a6afdaf8c6917a631d21e30e4091c.tar.bz2 |
prj-conf.ads, [...]: New files part of the project manager.
2009-06-23 Emmanuel Briot <briot@adacore.com>
* prj-conf.ads, prj-conf.adb: New files part of the project manager.
From-SVN: r148835
-rw-r--r-- | gcc/ada/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/ada/prj-conf.adb | 1060 | ||||
-rw-r--r-- | gcc/ada/prj-conf.ads | 140 |
3 files changed, 1204 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 69ea312..baef841 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2009-06-23 Emmanuel Briot <briot@adacore.com> + + * prj-conf.ads, prj-conf.adb: New files part of the project manager. + 2009-06-23 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Derive_Subprogram): If the inherited subprogram is a diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb new file mode 100644 index 0000000..8ae9f79 --- /dev/null +++ b/gcc/ada/prj-conf.adb @@ -0,0 +1,1060 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O N F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Directories; use Ada.Directories; +with GNAT.HTable; use GNAT.HTable; +with Makeutl; use Makeutl; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Err; use Prj.Err; +with Prj.Part; +with Prj.Proc; use Prj.Proc; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Prj; use Prj; +with Sinput.P; +with Snames; use Snames; +with System.Case_Util; use System.Case_Util; +with System; + +package body Prj.Conf is + + Auto_Cgpr : constant String := "auto.cgpr"; + + Default_Name : constant String := "default.cgpr"; + -- Default configuration file that will be used if found + + Config_Project_Env_Var : constant String := "GPR_CONFIG"; + -- Name of the environment variable that provides the name of the + -- configuration file to use. + + Gprconfig_Name : constant String := "gprconfig"; + + package RTS_Languages is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Stores the runtime names for the various languages. This is in general + -- set from a --RTS command line option. + + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations); + -- Process the attributes in the config declarations. + -- For single string values, if the attribute is not declared in the user + -- declarations, declare it with the value in the config declarations. + -- For string list values, prepend the value in the user declarations with + -- the value in the config declarations. + + function Locate_Config_File (Name : String) return String_Access; + -- Search for Name in the config files directory. Return full path if + -- found, or null otherwise + + function Check_Target + (Config_File : Prj.Project_Id; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Target : String := "") return Boolean; + -- Check that the config file's target matches Target. + -- Target should be set to the empty string when the user did not specify + -- a target. + -- If the target in the configuration file is invalid, this function will + -- call Osint.Fail to report a fatal error message and stop the program. + -- Autoconf_Specified should be set to True if the user has used --autoconf + + -------------------- + -- Add_Attributes -- + -------------------- + + procedure Add_Attributes + (Project_Tree : Project_Tree_Ref; + Conf_Decl : Declarations; + User_Decl : in out Declarations) + is + Conf_Attr_Id : Variable_Id; + Conf_Attr : Variable; + Conf_Array_Id : Array_Id; + Conf_Array : Array_Data; + Conf_Array_Elem_Id : Array_Element_Id; + Conf_Array_Elem : Array_Element; + Conf_List : String_List_Id; + Conf_List_Elem : String_Element; + + User_Attr_Id : Variable_Id; + User_Attr : Variable; + User_Array_Id : Array_Id; + User_Array : Array_Data; + User_Array_Elem_Id : Array_Element_Id; + User_Array_Elem : Array_Element; + + begin + Conf_Attr_Id := Conf_Decl.Attributes; + User_Attr_Id := User_Decl.Attributes; + + while Conf_Attr_Id /= No_Variable loop + Conf_Attr := + Project_Tree.Variable_Elements.Table (Conf_Attr_Id); + User_Attr := + Project_Tree.Variable_Elements.Table (User_Attr_Id); + + if not Conf_Attr.Value.Default then + if User_Attr.Value.Default then + + -- No attribute declared in user project file: just copy the + -- value of the configuration attribute. + + User_Attr.Value := Conf_Attr.Value; + Project_Tree.Variable_Elements.Table (User_Attr_Id) := + User_Attr; + + elsif User_Attr.Value.Kind = List and then + Conf_Attr.Value.Values /= Nil_String + then + + -- List attribute declared in both the user project and the + -- configuration project: prepend the user list with the + -- configuration list. + + declare + Conf_List : String_List_Id := + Conf_Attr.Value.Values; + Conf_Elem : String_Element; + User_List : constant String_List_Id := + User_Attr.Value.Values; + New_List : String_List_Id; + New_Elem : String_Element; + + begin + + -- Create new list + + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + New_List := String_Element_Table.Last + (Project_Tree.String_Elements); + + -- Value of attribute is new list + + User_Attr.Value.Values := New_List; + Project_Tree.Variable_Elements.Table (User_Attr_Id) := + User_Attr; + + loop + + -- Get each element of configuration list + + Conf_Elem := + Project_Tree.String_Elements.Table (Conf_List); + New_Elem := Conf_Elem; + Conf_List := Conf_Elem.Next; + + if Conf_List = Nil_String then + + -- If it is the last element in the list, connect to + -- first element of user list, and we are done. + + New_Elem.Next := User_List; + Project_Tree.String_Elements.Table + (New_List) := New_Elem; + exit; + + else + + -- If it is not the last element in the list, add to + -- new list. + + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + New_Elem.Next := + String_Element_Table.Last + (Project_Tree.String_Elements); + Project_Tree.String_Elements.Table + (New_List) := New_Elem; + New_List := New_Elem.Next; + end if; + end loop; + end; + end if; + end if; + + Conf_Attr_Id := Conf_Attr.Next; + User_Attr_Id := User_Attr.Next; + end loop; + + Conf_Array_Id := Conf_Decl.Arrays; + while Conf_Array_Id /= No_Array loop + Conf_Array := Project_Tree.Arrays.Table (Conf_Array_Id); + + User_Array_Id := User_Decl.Arrays; + while User_Array_Id /= No_Array loop + User_Array := Project_Tree.Arrays.Table (User_Array_Id); + exit when User_Array.Name = Conf_Array.Name; + User_Array_Id := User_Array.Next; + end loop; + + -- If this associative array does not exist in the user project file, + -- do a shallow copy of the full associative array. + + if User_Array_Id = No_Array then + Array_Table.Increment_Last (Project_Tree.Arrays); + User_Array := Conf_Array; + User_Array.Next := User_Decl.Arrays; + User_Decl.Arrays := Array_Table.Last (Project_Tree.Arrays); + Project_Tree.Arrays.Table (User_Decl.Arrays) := User_Array; + + else + -- Otherwise, check each array element + + Conf_Array_Elem_Id := Conf_Array.Value; + while Conf_Array_Elem_Id /= No_Array_Element loop + Conf_Array_Elem := + Project_Tree.Array_Elements.Table (Conf_Array_Elem_Id); + + User_Array_Elem_Id := User_Array.Value; + while User_Array_Elem_Id /= No_Array_Element loop + User_Array_Elem := + Project_Tree.Array_Elements.Table (User_Array_Elem_Id); + exit when User_Array_Elem.Index = Conf_Array_Elem.Index; + User_Array_Elem_Id := User_Array_Elem.Next; + end loop; + + -- If the array element does not exist in the user array, + -- insert a shallow copy of the conf array element in the + -- user array. + + if User_Array_Elem_Id = No_Array_Element then + Array_Element_Table.Increment_Last + (Project_Tree.Array_Elements); + User_Array_Elem := Conf_Array_Elem; + User_Array_Elem.Next := User_Array.Value; + User_Array.Value := + Array_Element_Table.Last (Project_Tree.Array_Elements); + Project_Tree.Array_Elements.Table (User_Array.Value) := + User_Array_Elem; + Project_Tree.Arrays.Table (User_Array_Id) := User_Array; + + -- Otherwise, if the value is a string list, prepend the + -- user array element with the conf array element value. + + elsif Conf_Array_Elem.Value.Kind = List then + Conf_List := Conf_Array_Elem.Value.Values; + + if Conf_List /= Nil_String then + declare + Link : constant String_List_Id := + User_Array_Elem.Value.Values; + Previous : String_List_Id := Nil_String; + Next : String_List_Id; + begin + loop + Conf_List_Elem := + Project_Tree.String_Elements.Table + (Conf_List); + String_Element_Table.Increment_Last + (Project_Tree.String_Elements); + Next := + String_Element_Table.Last + (Project_Tree.String_Elements); + Project_Tree.String_Elements.Table (Next) := + Conf_List_Elem; + + if Previous = Nil_String then + User_Array_Elem.Value.Values := Next; + Project_Tree.Array_Elements.Table + (User_Array_Elem_Id) := User_Array_Elem; + + else + Project_Tree.String_Elements.Table + (Previous).Next := Next; + end if; + + Previous := Next; + + Conf_List := Conf_List_Elem.Next; + + if Conf_List = Nil_String then + Project_Tree.String_Elements.Table + (Previous).Next := Link; + exit; + end if; + end loop; + end; + end if; + end if; + + Conf_Array_Elem_Id := Conf_Array_Elem.Next; + end loop; + end if; + + Conf_Array_Id := Conf_Array.Next; + end loop; + end Add_Attributes; + + ------------------------ + -- Locate_Config_File -- + ------------------------ + + function Locate_Config_File (Name : String) return String_Access is + Prefix_Path : constant String := Executable_Prefix_Path; + begin + if Prefix_Path'Length /= 0 then + return Locate_Regular_File + (Name, + "." & Path_Separator & + Prefix_Path & "share" & Directory_Separator & "gpr"); + + else + return Locate_Regular_File (Name, "."); + end if; + end Locate_Config_File; + + ------------------ + -- Check_Target -- + ------------------ + + function Check_Target + (Config_File : Project_Id; + Autoconf_Specified : Boolean; + Project_Tree : Prj.Project_Tree_Ref; + Target : String := "") return Boolean + is + Variable : constant Variable_Value := + Value_Of (Name_Target, Config_File.Decl.Attributes, Project_Tree); + Tgt_Name : Name_Id := No_Name; + OK : Boolean; + begin + if Variable /= Nil_Variable_Value and then not Variable.Default then + Tgt_Name := Variable.Value; + end if; + + if Target = "" then + OK := not Autoconf_Specified or 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 + Osint.Fail ("invalid target name """ & + Get_Name_String (Tgt_Name) & + """ in configuration"); + + else + Osint.Fail ("no target specified in configuration file"); + end if; + end if; + end if; + + return True; + end Check_Target; + + -------------------------------------- + -- Get_Or_Create_Configuration_File -- + -------------------------------------- + + procedure Get_Or_Create_Configuration_File + (Project : Project_Id; + Project_Tree : Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Allow_Automatic_Generation : Boolean; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Target_Name : String := ""; + Normalized_Hostname : String; + Packages_To_Check : String_List_Access := null; + Config : out Prj.Project_Id; + Config_File_Path : out String_Access; + Automatically_Generated : out Boolean) + is + function Default_File_Name return String; + -- Return the name of the default config file that should be tested + + procedure Do_Autoconf; + -- Generate a new config file through gprconfig + + function Get_Config_Switches return Argument_List_Access; + -- Return the --config switches to use for gprconfig + + function Might_Have_Sources (Project : Project_Id) return Boolean; + -- True if the specified project might have sources (ie the user has not + -- explicitly specified it. We haven't checked the file system, nor do + -- we need to at this stage. + + ----------------------- + -- Default_File_Name -- + ----------------------- + + function Default_File_Name return String is + Ada_RTS : constant String := Runtime_Name_For (Name_Ada); + Tmp : String_Access; + begin + if Target_Name /= "" then + if Ada_RTS /= "" then + return Target_Name & '-' & Ada_RTS + & Config_Project_File_Extension; + else + return Target_Name & Config_Project_File_Extension; + end if; + + elsif Ada_RTS /= "" then + return Ada_RTS & Config_Project_File_Extension; + + else + Tmp := Getenv (Config_Project_Env_Var); + + declare + T : constant String := Tmp.all; + begin + Free (Tmp); + + if T'Length = 0 then + return Default_Name; + else + return T; + end if; + end; + end if; + end Default_File_Name; + + ------------------------ + -- Might_Have_Sources -- + ------------------------ + + function Might_Have_Sources (Project : Project_Id) return Boolean is + Variable : Variable_Value; + begin + Variable := + Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, + Project_Tree); + + if Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String + then + Variable := + Value_Of + (Name_Source_Files, + Project.Decl.Attributes, + Project_Tree); + return Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String; + else + return False; + end if; + end Might_Have_Sources; + + ------------------------- + -- Get_Config_Switches -- + ------------------------- + + function Get_Config_Switches return Argument_List_Access is + package Language_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Hash table to keep the languages used in the project tree + + IDE : constant Package_Id := + Value_Of + (Name_Ide, + Project.Decl.Packages, + Project_Tree); + + Prj_Iter : Project_List; + List : String_List_Id; + Elem : String_Element; + Lang : Name_Id; + Variable : Variable_Value; + Name : Name_Id; + Count : Natural; + Result : Argument_List_Access; + + begin + Prj_Iter := Project_Tree.Projects; + while Prj_Iter /= null loop + if Might_Have_Sources (Prj_Iter.Project) then + Variable := + Value_Of + (Name_Languages, + Prj_Iter.Project.Decl.Attributes, + Project_Tree); + + if Variable = Nil_Variable_Value + or else Variable.Default + then + -- Languages is not declared. If it is not an extending + -- project, check for Default_Language + + if Prj_Iter.Project.Extends = No_Project then + Variable := + Value_Of + (Name_Default_Language, + Prj_Iter.Project.Decl.Attributes, + Project_Tree); + + if Variable /= Nil_Variable_Value and then + not Variable.Default + then + Get_Name_String (Variable.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + else + -- If no language is declared, default to Ada + + Language_Htable.Set (Name_Ada, Name_Ada); + end if; + end if; + + elsif Variable.Values /= Nil_String then + + -- Attribute Languages is declared with a non empty + -- list: put all the languages in Language_HTable. + + List := Variable.Values; + while List /= Nil_String loop + Elem := Project_Tree.String_Elements.Table (List); + + Get_Name_String (Elem.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + List := Elem.Next; + end loop; + end if; + end if; + + Prj_Iter := Prj_Iter.Next; + end loop; + + Name := Language_Htable.Get_First; + Count := 0; + + while Name /= No_Name loop + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + Result := new String_List (1 .. Count); + Count := 1; + Name := Language_Htable.Get_First; + + while Name /= No_Name loop + -- Check if IDE'Compiler_Command is declared for the language. + -- If it is, use its value to invoke gprconfig. + + Variable := + Value_Of + (Name, + Attribute_Or_Array_Name => Name_Compiler_Command, + In_Package => IDE, + In_Tree => Project_Tree, + Force_Lower_Case_Index => True); + + declare + Config_Command : constant String := + "--config=" & Get_Name_String (Name); + + Runtime_Name : constant String := + Runtime_Name_For (Name); + + begin + if Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0 + then + Result (Count) := + new String'(Config_Command & ",," & Runtime_Name); + + else + declare + Compiler_Command : constant String := + Get_Name_String (Variable.Value); + + begin + if Is_Absolute_Path (Compiler_Command) then + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & "," & + Containing_Directory (Compiler_Command) & "," & + Simple_Name (Compiler_Command)); + else + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & ",," & + Compiler_Command); + end if; + end; + end if; + end; + + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + return Result; + end Get_Config_Switches; + + ----------------- + -- Do_Autoconf -- + ----------------- + + procedure Do_Autoconf is + Obj_Dir : constant Variable_Value := + Value_Of (Name_Object_Dir, Project.Decl.Attributes, Project_Tree); + + Gprconfig_Path : String_Access; + Success : Boolean; + begin + Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); + + if Gprconfig_Path = null then + Fail ("could not locate gprconfig for auto-configuration"); + end if; + + -- First, find the object directory of the user's project + + if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then + Get_Name_String (Project.Directory.Name); + + else + if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then + Get_Name_String (Obj_Dir.Value); + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (Get_Name_String (Project.Directory.Name)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); + end if; + end if; + + if Subdirs /= null then + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Subdirs.all); + end if; + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '/' then + Name_Buffer (J) := Directory_Separator; + end if; + end loop; + + declare + Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); + Switches : Argument_List_Access := Get_Config_Switches; + Args : Argument_List (1 .. 5); + Arg_Last : Positive; + + 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 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 => + Fail ("could not create object directory " & Obj_Dir); + end; + end if; + + if not Is_Directory (Obj_Dir) then + Fail ("object directory " & Obj_Dir & " does not exist"); + end if; + + -- Invoke gprconfig + + Args (1) := new String'("--batch"); + Args (2) := new String'("-o"); + + -- If no config file was specified, set the auto.cgpr one + + if Config_File_Name = "" then + Args (3) := new String' + (Obj_Dir & Directory_Separator & Auto_Cgpr); + else + Args (3) := new String'(Config_File_Name); + end if; + + if Target_Name = "" then + Args (4) := new String'("--target=" & Normalized_Hostname); + else + Args (4) := new String'("--target=" & Target_Name); + end if; + + Arg_Last := 4; + + 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 Switches'Range loop + Write_Char (' '); + Write_Str (Switches (J).all); + end loop; + + Write_Eol; + + elsif not Quiet_Output then + Write_Str ("creating "); + Write_Str (Simple_Name (Args (3).all)); + Write_Eol; + end if; + + Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all, + Success); + + Free (Switches); + + Config_File_Path := Locate_Config_File (Args (3).all); + + if Config_File_Path = null then + Fail ("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 + Free (Config_File_Path); + + 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 + Osint.Fail + ("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 + Do_Autoconf; + end if; + + -- Parse the configuration file + + if Verbose_Mode then + Write_Str ("Checking configuration "); + Write_Line (Config_File_Path.all); + end if; + + Prj.Part.Parse + (In_Tree => Project_Node_Tree, + Project => Config_Project_Node, + Project_File_Name => Config_File_Path.all, + Always_Errout_Finalize => False, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Directory, + Is_Config_File => True); + + 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, + Report_Error => null, + Reset_Tree => False); + end if; + + if Config_Project_Node = Empty_Node + or else Config = No_Project + then + Osint.Fail + ("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 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; + + ------------------------------------ + -- 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; + 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 + Main_Config_Project : Project_Id; + Success : Boolean; + + begin + -- Parse the user project tree + + Prj.Initialize (Project_Tree); + Prj.Tree.Initialize (Project_Node_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, + Always_Errout_Finalize => False, + Packages_To_Check => Packages_To_Check, + Current_Directory => Current_Directory, + Is_Config_File => False); + + if User_Project_Node = Empty_Node then + User_Project_Node := Empty_Node; + return; + end if; + + 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, + Report_Error => null); + + if not Success then + Main_Project := No_Project; + return; + 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, + 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); + + if On_Load_Config /= null then + On_Load_Config + (Config_File => Main_Config_Project, + Project_Tree => Project_Tree); + end if; + + Apply_Config_File (Main_Config_Project, Project_Tree); + + -- Finish processing the user's project + + Sinput.P.Reset_First; + + 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, + Report_Error => null, + Current_Dir => Current_Directory, + When_No_Sources => Warning, + Is_Config_File => False); + + if not Success then + Prj.Err.Finalize; + Osint.Fail ("""" & Project_File_Name & """ processing failed"); + end if; + end Parse_Project_And_Apply_Config; + + ----------------------- + -- Apply_Config_File -- + ----------------------- + + procedure Apply_Config_File + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref) + is + 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 + 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 := Project_Tree.Packages.Table (Conf_Pack_Id); + + User_Pack_Id := User_Decl.Packages; + while User_Pack_Id /= No_Package loop + User_Pack := Project_Tree.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 (Project_Tree.Packages); + User_Pack := Conf_Pack; + User_Pack.Next := User_Decl.Packages; + User_Decl.Packages := + Package_Table.Last (Project_Tree.Packages); + Project_Tree.Packages.Table (User_Decl.Packages) := + User_Pack; + + else + Add_Attributes + (Project_Tree => Project_Tree, + Conf_Decl => Conf_Pack.Decl, + User_Decl => Project_Tree.Packages.Table + (User_Pack_Id).Decl); + end if; + + Conf_Pack_Id := Conf_Pack.Next; + end loop; + + Proj.Project.Decl := User_Decl; + end if; + + Proj := Proj.Next; + end loop; + end Apply_Config_File; + + --------------------- + -- 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; + + ---------------------- + -- 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; + +end Prj.Conf; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads new file mode 100644 index 0000000..773e3ba --- /dev/null +++ b/gcc/ada/prj-conf.ads @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O N F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The following package manipulates the configuration files. + +with Prj.Tree; + +package Prj.Conf is + + type Config_File_Hook is access procedure + (Config_File : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref); + -- Hook called after the config file has been parsed. This lets the + -- application do last minute changes to it (GPS uses this to add the + -- default naming schemes for instance). At that point, the config file has + -- not been applied to the project yet. + + 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; + 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); + -- Find the main configuration project and parse the project tree rooted at + -- this configuration project. + -- If the processing fails, Main_Project is set to No_Project. If the error + -- happend while parsing the project itself (ie creating the tree), + -- User_Project_Node is also set to Empty_Node + -- + -- Autoconf_Specified indicates whether the user has specified --autoconf. + -- If this is the case, the config file might be (re)generated, as + -- appropriate, to match languages and target if the one specified doesn't + -- already match. + -- Normalized_Hostname is the host on which gprbuild is returned, + -- normalized so that we can more easily compare it with what is stored in + -- configuration files. It is used when the target is unspecified, although + -- we need to know the target specified by the user (Target_Name) when + -- computing the name of the default config file that should be used. + -- + -- If specified, On_Load_Config is called just after the config file has + -- been created/loaded. You can then modify it before it is later applied + -- to the project itself. + + procedure Get_Or_Create_Configuration_File + (Project : Prj.Project_Id; + Project_Tree : Prj.Project_Tree_Ref; + Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; + Allow_Automatic_Generation : Boolean; + Config_File_Name : String := ""; + Autoconf_Specified : Boolean; + Target_Name : String := ""; + Normalized_Hostname : String; + Packages_To_Check : String_List_Access := null; + Config : out Prj.Project_Id; + Config_File_Path : out String_Access; + Automatically_Generated : out Boolean); + -- Compute the name of the configuration file that should be used. If no + -- default configuration file is found, a new one will be automatically + -- generated if Allow_Automatic_Generation is true (otherwise an error + -- reported to the user via Osint.Fail). + -- On exit, Configuration_Project_Path is never null (if none could be + -- found, Os.Fail was called and the program exited anyway). + -- The choice and generation of a configuration file depends on several + -- attributes of the user's project file (given by the Project argument), + -- like the list of languages that must be supported. Project must + -- therefore have been partially processed (phase one of the processing + -- only). + -- Config_File_Name should be set to the name of the config file specified + -- by the user (either through gprbuild's --config or --autoconf switches). + -- In the latter case, Autoconf_Specified should be set to true, to + -- indicate that the configuration file can be regenerated to match target + -- and languages. This name can either be an absolute path, or the a base + -- name that will be searched in the default config file directories (which + -- depends on the installation path for the tools). + -- Target_Name is used to chose among several possibilities + -- the configuration file that will be used. + -- + -- If a project file could be found, it is automatically parsed and + -- processed (and Packages_To_Check is used to indicate which packages + -- should be processed) + + 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. + + -------------- + -- Runtimes -- + -------------- + + procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String); + -- Specifies the runtime to use for a specific language. Most of the time + -- this should be used for Ada, but other languages can also specify their + -- own runtime. This is in general specified via the --RTS command line + -- switch, and results in a specific component passed to gprconfig's + -- --config switch then automatically generating a configuration file. + + function Runtime_Name_For (Language : Name_Id) return String; + -- Returns the runtime name for a language. Returns an empty string if + -- no runtime was specified for the language using option --RTS. + +end Prj.Conf; |