diff options
author | Vincent Celier <celier@adacore.com> | 2007-04-06 11:25:16 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2007-04-06 11:25:16 +0200 |
commit | 2f41ec1a8fe5eab706ed223ab468de003d1995f0 (patch) | |
tree | 47b104101e9f0a4d83635f8e134fc642ba236db6 | |
parent | 874a0341c8306d74db689405040a4bc4f550085a (diff) | |
download | gcc-2f41ec1a8fe5eab706ed223ab468de003d1995f0.zip gcc-2f41ec1a8fe5eab706ed223ab468de003d1995f0.tar.gz gcc-2f41ec1a8fe5eab706ed223ab468de003d1995f0.tar.bz2 |
prj-ext.adb (Initialize_Project_Path): New procedure that initialize the default project path...
2007-04-06 Vincent Celier <celier@adacore.com>
* prj-ext.adb (Initialize_Project_Path): New procedure that initialize
the default project path, initially done during elaboration of the
package.
If the prefix returned by Sdefault is null, get the prefix from a call
to Executable_Prefix_Path.
(Project_Path): Call Initialize_Project_Path if Current_Project_Path is
null.
* prj-nmsc.adb (Get_Path_Names_And_Record_Sources): Use the non
canonical directory name to open the directory from which files are
retrieved.
(Record_Other_Sources): Idem.
(Locate_Directory): Add the possibility to create automatically missing
directories when Setup_Projects is True.
Call Locate_Directory so that the directory will be created when
Setup_Projects is True, for object dir, library dir, library ALI dir,
library source copy dir and exec dir.
* prj-pp.adb (Max_Line_Length): Set to 255 for compatibility with older
versions of GNAT.
From-SVN: r123589
-rw-r--r-- | gcc/ada/prj-ext.adb | 190 | ||||
-rw-r--r-- | gcc/ada/prj-nmsc.adb | 268 | ||||
-rw-r--r-- | gcc/ada/prj-pp.adb | 8 |
3 files changed, 261 insertions, 205 deletions
diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index 649c2ba..f30c709 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -25,6 +25,7 @@ ------------------------------------------------------------------------------ with Hostparm; +with Makeutl; use Makeutl; with Namet; use Namet; with Output; use Output; with Osint; use Osint; @@ -48,8 +49,11 @@ package body Prj.Ext is No_Project_Default_Dir : constant String := "-"; Current_Project_Path : String_Access; - -- The project path. Initialized during elaboration of package Contains at - -- least the current working directory. + -- The project path. Initialized by procedure Initialize_Project_Path + -- below. + + procedure Initialize_Project_Path; + -- Initialize Current_Project_Path package Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -107,81 +111,11 @@ package body Prj.Ext is return False; end Check; - ------------------ - -- Project_Path -- - ------------------ - - function Project_Path return String is - begin - return Current_Project_Path.all; - end Project_Path; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - Htable.Reset; - end Reset; - - ---------------------- - -- Set_Project_Path -- - ---------------------- - - procedure Set_Project_Path (New_Path : String) is - begin - Free (Current_Project_Path); - Current_Project_Path := new String'(New_Path); - end Set_Project_Path; - - -------------- - -- Value_Of -- - -------------- - - function Value_Of - (External_Name : Name_Id; - With_Default : Name_Id := No_Name) - return Name_Id - is - The_Value : Name_Id; - Name : String := Get_Name_String (External_Name); - - begin - Canonical_Case_File_Name (Name); - Name_Len := Name'Length; - Name_Buffer (1 .. Name_Len) := Name; - The_Value := Htable.Get (Name_Find); + ----------------------------- + -- Initialize_Project_Path -- + ----------------------------- - if The_Value /= No_Name then - return The_Value; - end if; - - -- Find if it is an environment, if it is, put value in the hash table - - declare - Env_Value : String_Access := Getenv (Name); - - begin - if Env_Value /= null and then Env_Value'Length > 0 then - Name_Len := Env_Value'Length; - Name_Buffer (1 .. Name_Len) := Env_Value.all; - The_Value := Name_Find; - Htable.Set (External_Name, The_Value); - Free (Env_Value); - return The_Value; - - else - Free (Env_Value); - return With_Default; - end if; - end; - end Value_Of; - -begin - -- Initialize Current_Project_Path during package elaboration - - declare + procedure Initialize_Project_Path is Add_Default_Dir : Boolean := True; First : Positive; Last : Positive; @@ -286,13 +220,105 @@ begin -- Set the initial value of Current_Project_Path if Add_Default_Dir then - Current_Project_Path := - new String'(Name_Buffer (1 .. Name_Len) & Path_Separator & - Sdefault.Search_Dir_Prefix.all & ".." & - Directory_Separator & ".." & Directory_Separator & - ".." & Directory_Separator & "gnat"); + declare + Prefix : String_Ptr := Sdefault.Search_Dir_Prefix; + begin + if Prefix = null then + Prefix := new String'(Executable_Prefix_Path); + + if Prefix.all /= "" then + Current_Project_Path := + new String'(Name_Buffer (1 .. Name_Len) & Path_Separator & + Prefix.all & Directory_Separator & "gnat"); + end if; + + else + Current_Project_Path := + new String'(Name_Buffer (1 .. Name_Len) & Path_Separator & + Prefix.all & + ".." & Directory_Separator & + ".." & Directory_Separator & + ".." & Directory_Separator & "gnat"); + end if; + end; else Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len)); end if; - end; + end Initialize_Project_Path; + + ------------------ + -- Project_Path -- + ------------------ + + function Project_Path return String is + begin + if Current_Project_Path = null then + Initialize_Project_Path; + end if; + + return Current_Project_Path.all; + end Project_Path; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + Htable.Reset; + end Reset; + + ---------------------- + -- Set_Project_Path -- + ---------------------- + + procedure Set_Project_Path (New_Path : String) is + begin + Free (Current_Project_Path); + Current_Project_Path := new String'(New_Path); + end Set_Project_Path; + + -------------- + -- Value_Of -- + -------------- + + function Value_Of + (External_Name : Name_Id; + With_Default : Name_Id := No_Name) + return Name_Id + is + The_Value : Name_Id; + Name : String := Get_Name_String (External_Name); + + begin + Canonical_Case_File_Name (Name); + Name_Len := Name'Length; + Name_Buffer (1 .. Name_Len) := Name; + The_Value := Htable.Get (Name_Find); + + if The_Value /= No_Name then + return The_Value; + end if; + + -- Find if it is an environment, if it is, put value in the hash table + + declare + Env_Value : String_Access := Getenv (Name); + + begin + if Env_Value /= null and then Env_Value'Length > 0 then + Name_Len := Env_Value'Length; + Name_Buffer (1 .. Name_Len) := Env_Value.all; + The_Value := Name_Find; + Htable.Set (External_Name, The_Value); + Free (Env_Value); + return The_Value; + + else + Free (Env_Value); + return With_Default; + end if; + end; + end Value_Of; + end Prj.Ext; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 88b00f4..e5ae184 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -29,6 +29,7 @@ with Fmap; use Fmap; with Hostparm; with MLib.Tgt; use MLib.Tgt; with Namet; use Namet; +with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Prj.Env; use Prj.Env; @@ -40,6 +41,7 @@ with Table; use Table; with Targparm; use Targparm; with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories; use Ada.Directories; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; @@ -295,22 +297,30 @@ package body Prj.Nmsc is -- a spec suffix, a body suffix or a separate suffix. procedure Locate_Directory - (Name : Name_Id; - Parent : Name_Id; - Dir : out Name_Id; - Display : out Name_Id); - -- Locate a directory (returns No_Name for Dir and Display if directory - -- does not exist). Name is the directory name. Parent is the root - -- directory, if Name is a relative path name. Dir is the canonical case - -- path name of the directory, Display is the directory path name for - -- display purposes. + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Name : Name_Id; + Parent : Name_Id; + Dir : out Name_Id; + Display : out Name_Id; + Create : String := ""; + Location : Source_Ptr := No_Location); + -- Locate a directory. Name is the directory name. Parent is the root + -- directory, if Name a relative path name. Dir is set to the canonical + -- case path name of the directory, and Display is the directory path name + -- for display purposes. If the directory does not exist and Project_Setup + -- is True and Create is a non null string, an attempt is made to create + -- the directory. If the directory does not exist and Project_Setup is + -- false, then Dir and Display are set to No_Name. procedure Look_For_Sources (Project : Project_Id; In_Tree : Project_Tree_Ref; Data : in out Project_Data; Follow_Links : Boolean); - -- Find all the sources of a project + -- Find all the sources of project Project in project tree In_Tree and + -- update its Data accordingly. Resolve symbolic links in the path names + -- if Follow_Links is True. function Path_Name_Of (File_Name : Name_Id; @@ -634,21 +644,21 @@ package body Prj.Nmsc is if Naming /= In_Tree.Private_Part.Default_Naming then declare - Dot_Replacement : constant String := - Get_Name_String - (Naming.Dot_Replacement); + Dot_Replacement : constant String := + Get_Name_String + (Naming.Dot_Replacement); - Spec_Suffix : constant String := - Get_Name_String - (Naming.Ada_Spec_Suffix); + Spec_Suffix : constant String := + Get_Name_String + (Naming.Ada_Spec_Suffix); - Body_Suffix : constant String := - Get_Name_String - (Naming.Ada_Body_Suffix); + Body_Suffix : constant String := + Get_Name_String + (Naming.Ada_Body_Suffix); - Separate_Suffix : constant String := - Get_Name_String - (Naming.Separate_Suffix); + Separate_Suffix : constant String := + Get_Name_String + (Naming.Separate_Suffix); begin -- Dot_Replacement cannot @@ -771,7 +781,7 @@ package body Prj.Nmsc is Suffix : String; Naming_Exception : Boolean) is - Name : String := Get_Name_String (File_Name); + Name : String := Get_Name_String (File_Name); Real_Location : Source_Ptr := Location; begin @@ -1401,23 +1411,23 @@ package body Prj.Nmsc is In_Tree : Project_Tree_Ref; Data : in out Project_Data) is - Attributes : constant Prj.Variable_Id := Data.Decl.Attributes; + Attributes : constant Prj.Variable_Id := Data.Decl.Attributes; - Lib_Dir : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Dir, Attributes, In_Tree); + Lib_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Dir, Attributes, In_Tree); - Lib_Name : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Name, Attributes, In_Tree); + Lib_Name : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Name, Attributes, In_Tree); - Lib_Version : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Version, Attributes, In_Tree); + Lib_Version : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Version, Attributes, In_Tree); - Lib_ALI_Dir : constant Prj.Variable_Value := - Prj.Util.Value_Of - (Snames.Name_Library_Ali_Dir, Attributes, In_Tree); + Lib_ALI_Dir : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Ali_Dir, Attributes, In_Tree); The_Lib_Kind : constant Prj.Variable_Value := Prj.Util.Value_Of @@ -1469,8 +1479,9 @@ package body Prj.Nmsc is -- Find path name, check that it is a directory Locate_Directory - (Lib_Dir.Value, Data.Display_Directory, - Data.Library_Dir, Data.Display_Library_Dir); + (Project, In_Tree, Lib_Dir.Value, Data.Display_Directory, + Data.Library_Dir, Data.Display_Library_Dir, Create => "library", + Location => Lib_Dir.Location); if Data.Library_Dir = No_Name then @@ -1641,8 +1652,9 @@ package body Prj.Nmsc is -- Find path name, check that it is a directory Locate_Directory - (Lib_ALI_Dir.Value, Data.Display_Directory, - Data.Library_ALI_Dir, Data.Display_Library_ALI_Dir); + (Project, In_Tree, Lib_ALI_Dir.Value, Data.Display_Directory, + Data.Library_ALI_Dir, Data.Display_Library_ALI_Dir, + Create => "library ALI", Location => Lib_ALI_Dir.Location); if Data.Library_ALI_Dir = No_Name then @@ -1865,7 +1877,7 @@ package body Prj.Nmsc is Naming_Id : constant Package_Id := Util.Value_Of (Name_Naming, Data.Decl.Packages, In_Tree); - Naming : Package_Element; + Naming : Package_Element; begin -- If there is a package Naming, we will put in Data.Naming @@ -2468,9 +2480,11 @@ package body Prj.Nmsc is begin Locate_Directory - (Dir_Id, Data.Display_Directory, + (Project, In_Tree, Dir_Id, Data.Display_Directory, Data.Library_Src_Dir, - Data.Display_Library_Src_Dir); + Data.Display_Library_Src_Dir, + Create => "library source copy", + Location => Lib_Src_Dir.Location); -- If directory does not exist, report an error @@ -2819,10 +2833,10 @@ package body Prj.Nmsc is Flag_Location : Source_Ptr) is Real_Location : Source_Ptr := Flag_Location; - Error_Buffer : String (1 .. 5_000); - Error_Last : Natural := 0; - Msg_Name : Natural := 0; - First : Positive := Msg'First; + Error_Buffer : String (1 .. 5_000); + Error_Last : Natural := 0; + Msg_Name : Natural := 0; + First : Positive := Msg'First; procedure Add (C : Character); -- Add a character to the buffer @@ -3081,13 +3095,13 @@ package body Prj.Nmsc is In_Tree : Project_Tree_Ref; Data : in out Project_Data) is - Object_Dir : constant Variable_Value := - Util.Value_Of - (Name_Object_Dir, Data.Decl.Attributes, In_Tree); + Object_Dir : constant Variable_Value := + Util.Value_Of + (Name_Object_Dir, Data.Decl.Attributes, In_Tree); - Exec_Dir : constant Variable_Value := - Util.Value_Of - (Name_Exec_Dir, Data.Decl.Attributes, In_Tree); + Exec_Dir : constant Variable_Value := + Util.Value_Of + (Name_Exec_Dir, Data.Decl.Attributes, In_Tree); Source_Dirs : constant Variable_Value := Util.Value_Of @@ -3354,7 +3368,9 @@ package body Prj.Nmsc is begin Locate_Directory - (From, Data.Display_Directory, Path_Name, Display_Path_Name); + (Project, In_Tree, + From, Data.Display_Directory, + Path_Name, Display_Path_Name); if Path_Name = No_Name then Err_Vars.Error_Msg_Name_1 := From; @@ -3438,8 +3454,9 @@ package body Prj.Nmsc is -- We check that the specified object directory does exist Locate_Directory - (Object_Dir.Value, Data.Display_Directory, - Data.Object_Directory, Data.Display_Object_Dir); + (Project, In_Tree, Object_Dir.Value, Data.Display_Directory, + Data.Object_Directory, Data.Display_Object_Dir, + Create => "object", Location => Object_Dir.Location); if Data.Object_Directory = No_Name then @@ -3498,8 +3515,9 @@ package body Prj.Nmsc is -- does exist. Locate_Directory - (Exec_Dir.Value, Data.Directory, - Data.Exec_Directory, Data.Display_Exec_Dir); + (Project, In_Tree, Exec_Dir.Value, Data.Directory, + Data.Exec_Directory, Data.Display_Exec_Dir, + Create => "exec", Location => Exec_Dir.Location); if Data.Exec_Directory = No_Name then Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value; @@ -3619,7 +3637,8 @@ package body Prj.Nmsc is procedure Get_Mains (Project : Project_Id; In_Tree : Project_Tree_Ref; - Data : in out Project_Data) is + Data : in out Project_Data) + is Mains : constant Variable_Value := Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes, In_Tree); @@ -3718,8 +3737,8 @@ package body Prj.Nmsc is Unit_Kind : out Spec_Or_Body; Needs_Pragma : out Boolean) is - Info_Id : Ada_Naming_Exception_Id - := Ada_Naming_Exceptions.Get (Canonical_File_Name); + Info_Id : Ada_Naming_Exception_Id := + Ada_Naming_Exceptions.Get (Canonical_File_Name); VMS_Name : Name_Id; begin @@ -4035,18 +4054,24 @@ package body Prj.Nmsc is ---------------------- procedure Locate_Directory - (Name : Name_Id; - Parent : Name_Id; - Dir : out Name_Id; - Display : out Name_Id) + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Name : Name_Id; + Parent : Name_Id; + Dir : out Name_Id; + Display : out Name_Id; + Create : String := ""; + Location : Source_Ptr := No_Location) is - The_Name : constant String := Get_Name_String (Name); + The_Name : constant String := Get_Name_String (Name); - The_Parent : constant String := - Get_Name_String (Parent) & Directory_Separator; + The_Parent : constant String := + Get_Name_String (Parent) & Directory_Separator; The_Parent_Last : constant Natural := - Compute_Directory_Last (The_Parent); + Compute_Directory_Last (The_Parent); + + Full_Name : Name_Id; begin if Current_Verbosity = High then @@ -4061,11 +4086,47 @@ package body Prj.Nmsc is Display := No_Name; if Is_Absolute_Path (The_Name) then - if Is_Directory (The_Name) then + Full_Name := Name; + + else + Name_Len := 0; + Add_Str_To_Name_Buffer + (The_Parent (The_Parent'First .. The_Parent_Last)); + Add_Str_To_Name_Buffer (The_Name); + Full_Name := Name_Find; + end if; + + declare + Full_Path_Name : constant String := Get_Name_String (Full_Name); + + begin + if Setup_Projects and then Create'Length > 0 + and then not Is_Directory (Full_Path_Name) + then + begin + Create_Path (Full_Path_Name); + + if not Quiet_Output then + Write_Str (Create); + Write_Str (" directory """); + Write_Str (Full_Path_Name); + Write_Line (""" created"); + end if; + + exception + when Use_Error => + Error_Msg + (Project, In_Tree, + "could not create " & Create & + " directory " & Full_Path_Name, + Location); + end; + end if; + if Is_Directory (Full_Path_Name) then declare Normed : constant String := Normalize_Pathname - (The_Name, + (Full_Path_Name, Resolve_Links => False, Case_Sensitive => True); @@ -4085,40 +4146,7 @@ package body Prj.Nmsc is Dir := Name_Find; end; end if; - - else - declare - Full_Path : constant String := - The_Parent (The_Parent'First .. The_Parent_Last) & - The_Name; - - begin - if Is_Directory (Full_Path) then - declare - Normed : constant String := - Normalize_Pathname - (Full_Path, - Resolve_Links => False, - Case_Sensitive => True); - - Canonical_Path : constant String := - Normalize_Pathname - (Normed, - Resolve_Links => True, - Case_Sensitive => False); - - begin - Name_Len := Normed'Length; - Name_Buffer (1 .. Name_Len) := Normed; - Display := Name_Find; - - Name_Len := Canonical_Path'Length; - Name_Buffer (1 .. Name_Len) := Canonical_Path; - Dir := Name_Find; - end; - end if; - end; - end if; + end; end Locate_Directory; ---------------------- @@ -4149,16 +4177,16 @@ package body Prj.Nmsc is Element : String_Element; Path : Name_Id; - Dir : Dir_Type; - Name : Name_Id; - Canonical_Name : Name_Id; - Name_Str : String (1 .. 1_024); - Last : Natural := 0; - NL : Name_Location; + Dir : Dir_Type; + Name : Name_Id; + Canonical_Name : Name_Id; + Name_Str : String (1 .. 1_024); + Last : Natural := 0; + NL : Name_Location; - Current_Source : String_List_Id := Nil_String; + Current_Source : String_List_Id := Nil_String; - First_Error : Boolean := True; + First_Error : Boolean := True; Source_Recorded : Boolean := False; @@ -4171,7 +4199,8 @@ package body Prj.Nmsc is Element := In_Tree.String_Elements.Table (Source_Dir); declare - Dir_Path : constant String := Get_Name_String (Element.Value); + Dir_Path : constant String := + Get_Name_String (Element.Display_Value); begin if Current_Verbosity = High then Write_Str ("checking directory """); @@ -4184,13 +4213,15 @@ package body Prj.Nmsc is loop Read (Dir, Name_Str, Last); exit when Last = 0; + Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); Name := Name_Find; + Canonical_Case_File_Name (Name_Str (1 .. Last)); - Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); Canonical_Name := Name_Find; + NL := Source_Names.Get (Canonical_Name); if NL /= No_Name_Location and then not NL.Found then @@ -4822,8 +4853,7 @@ package body Prj.Nmsc is is Current : Array_Element_Id := List; Element : Array_Element; - - Unit : Unit_Info; + Unit : Unit_Info; begin -- Traverse the list @@ -5194,8 +5224,8 @@ package body Prj.Nmsc is Element := In_Tree.String_Elements.Table (Source_Dir); declare - Dir_Path : constant String := Get_Name_String (Element.Value); - + Dir_Path : constant String := + Get_Name_String (Element.Display_Value); begin if Current_Verbosity = High then Write_Str ("checking directory """); diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index bf93059..d20e642 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2006, 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- -- @@ -26,7 +26,6 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; -with Hostparm; with Namet; use Namet; with Output; use Output; with Snames; @@ -37,8 +36,9 @@ package body Prj.PP is Not_Tested : array (Project_Node_Kind) of Boolean := (others => True); - Max_Line_Length : constant := Hostparm.Max_Line_Length - 5; - -- Maximum length of a line + Max_Line_Length : constant := 255; + -- Maximum length of a line. This is chosen to be compatible with older + -- versions of GNAT that had a strict limit on the maximum line length. Column : Natural := 0; -- Column number of the last character in the line. Used to avoid |