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

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);
-
-      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);
+   -----------------------------
+   -- Initialize_Project_Path --
+   -----------------------------
 
-      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
+         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 &
-                       Sdefault.Search_Dir_Prefix.all & ".." &
-                       Directory_Separator & ".." & Directory_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 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;

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;
+     (Project  : Project_Id;
+      In_Tree  : Project_Tree_Ref;
+      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.
+      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;
@@ -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
 
@@ -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
 
@@ -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,10 +4054,14 @@ package body Prj.Nmsc is
    ----------------------
 
    procedure Locate_Directory
-     (Name    : Name_Id;
+     (Project  : Project_Id;
+      In_Tree  : Project_Tree_Ref;
+      Name     : Name_Id;
       Parent   : Name_Id;
       Dir      : out Name_Id;
-      Display : out Name_Id)
+      Display  : out Name_Id;
+      Create   : String := "";
+      Location : Source_Ptr := No_Location)
    is
       The_Name        : constant String := Get_Name_String (Name);
 
@@ -4048,6 +4071,8 @@ package body Prj.Nmsc is
       The_Parent_Last : constant Natural :=
                           Compute_Directory_Last (The_Parent);
 
+      Full_Name       : Name_Id;
+
    begin
       if Current_Verbosity = High then
          Write_Str ("Locate_Directory (""");
@@ -4061,43 +4086,47 @@ package body Prj.Nmsc is
       Display := No_Name;
 
       if Is_Absolute_Path (The_Name) then
-         if Is_Directory (The_Name) then
-            declare
-               Normed : constant String :=
-                          Normalize_Pathname
-                            (The_Name,
-                             Resolve_Links  => False,
-                             Case_Sensitive => True);
-
-               Canonical_Path : constant String :=
-                                  Normalize_Pathname
-                                    (Normed,
-                                     Resolve_Links  => True,
-                                     Case_Sensitive => False);
+         Full_Name := Name;
 
-            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;
+      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;
 
-      else
       declare
-            Full_Path : constant String :=
-                          The_Parent (The_Parent'First .. The_Parent_Last) &
-                          The_Name;
+         Full_Path_Name : constant String := Get_Name_String (Full_Name);
 
       begin
-            if Is_Directory (Full_Path) then
+         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
-                               (Full_Path,
+                            (Full_Path_Name,
                              Resolve_Links  => False,
                              Case_Sensitive => True);
 
@@ -4118,7 +4147,6 @@ package body Prj.Nmsc is
             end;
          end if;
       end;
-      end if;
    end Locate_Directory;
 
    ----------------------
@@ -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,7 +4853,6 @@ package body Prj.Nmsc is
    is
       Current : Array_Element_Id := List;
       Element : Array_Element;
-
       Unit    : Unit_Info;
 
    begin
@@ -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 """);

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