Patchwork [Ada] Correct object path when binding extending SALs

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 9:28 a.m.
Message ID <20110829092817.GA21931@adacore.com>
Download mbox | patch
Permalink /patch/111998/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 9:28 a.m.
When binding a Stand-Alone library that is extending another Stand-Alone
library, ALI files that are not interfaces of the SAL project may not
be found, because the object path was incorrectly set.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-29  Vincent Celier  <celier@adacore.com>

	* makeutl.adb (Get_Directories): New procedure moved from Buildgpr and
	modified to compute correctly the object path of a SAL project that is
	extending another library project.
	(Write_Path_File): New procedure.
	* makeutl.ads (Directories): New table moved from Buildgpr
	(Get_Directories): New procedure moved from Buildgpr
	(Write_Path_File): New procedure
	* mlib-prj.adb (Build_Library): Use Makeutl.Get_Directories to set the
	paths before binding SALs, instead of Set_Ada_Paths.
	* prj-env.adb (Set_Path_File_Var): Procedure has been moved to package
	Prj.
	* prj.adb (Set_Path_File_Var): New procedure moved from Prj.Env
	(Current_Source_Path_File_Of): New function
	(Set_Current_Object_Path_File_Of): New procedure
	(Current_Source_Object_File_Of): New function
	(Set_Current_Object_Path_File_Of): New procedure
	* prj.ads (Set_Path_File_Var): New procedure moved from Prj.Env
	(Current_Source_Path_File_Of): New function
	(Set_Current_Object_Path_File_Of): New procedure
	(Current_Source_Object_File_Of): New function
	(Set_Current_Object_Path_File_Of): New procedure

Patch

Index: mlib-prj.adb
===================================================================
--- mlib-prj.adb	(revision 178155)
+++ mlib-prj.adb	(working copy)
@@ -25,6 +25,7 @@ 
 
 with ALI;      use ALI;
 with Gnatvsn;  use Gnatvsn;
+with Makeutl;  use Makeutl;
 with MLib.Fil; use MLib.Fil;
 with MLib.Tgt; use MLib.Tgt;
 with MLib.Utl; use MLib.Utl;
@@ -802,6 +803,9 @@ 
          end loop;
       end Process_Imported_Libraries;
 
+      Path_FD : File_Descriptor := Invalid_FD;
+      --  Used for setting the source and object paths
+
    --  Start of processing for Build_Library
 
    begin
@@ -1044,11 +1048,57 @@ 
 
             --  Set the paths
 
-            Set_Ada_Paths
-              (Project             => For_Project,
-               In_Tree             => In_Tree,
-               Including_Libraries => True);
+            --  First the source path
 
+            if For_Project.Include_Path_File = No_Path then
+               Get_Directories
+                 (Project_Tree => In_Tree,
+                  For_Project  => For_Project,
+                  Activity     => Compilation,
+                  Languages    => Ada_Only);
+
+               Create_New_Path_File
+                 (In_Tree.Shared, Path_FD, For_Project.Include_Path_File);
+
+               Write_Path_File (Path_FD);
+               Path_FD := Invalid_FD;
+
+            end if;
+
+            if Current_Source_Path_File_Of (In_Tree.Shared) /=
+              For_Project.Include_Path_File
+            then
+               Set_Current_Source_Path_File_Of
+                 (In_Tree.Shared,
+                 For_Project.Include_Path_File);
+               Set_Path_File_Var
+                 (Project_Include_Path_File,
+                  Get_Name_String (For_Project.Include_Path_File));
+            end if;
+
+            --  Then, the object path
+
+            Get_Directories
+              (Project_Tree => In_Tree,
+               For_Project  => For_Project,
+               Activity     => SAL_Binding,
+               Languages    => Ada_Only);
+
+            declare
+               Path_File_Name : Path_Name_Type;
+            begin
+               Create_New_Path_File (In_Tree.Shared, Path_FD, Path_File_Name);
+
+               Write_Path_File (Path_FD);
+               Path_FD := Invalid_FD;
+
+               Set_Path_File_Var
+                 (Project_Objects_Path_File,
+                  Get_Name_String (Path_File_Name));
+               Set_Current_Source_Path_File_Of
+                 (In_Tree.Shared, Path_File_Name);
+            end;
+
             --  Display the gnatbind command, if not in quiet output
 
             Display (Gnatbind);
Index: prj.adb
===================================================================
--- prj.adb	(revision 178155)
+++ prj.adb	(working copy)
@@ -27,6 +27,7 @@ 
 with Osint;    use Osint;
 with Output;   use Output;
 with Prj.Attr;
+with Prj.Com;
 with Prj.Err;  use Prj.Err;
 with Snames;   use Snames;
 with Uintp;    use Uintp;
@@ -113,6 +114,28 @@ 
       Last := Last + S'Length;
    end Add_To_Buffer;
 
+   ---------------------------------
+   -- Current_Object_Path_File_Of --
+   ---------------------------------
+
+   function Current_Object_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access)
+      return Path_Name_Type is
+   begin
+      return Shared.Private_Part.Current_Object_Path_File;
+   end Current_Object_Path_File_Of;
+
+   ---------------------------------
+   -- Current_Source_Path_File_Of --
+   ---------------------------------
+
+   function Current_Source_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access)
+      return Path_Name_Type is
+   begin
+      return Shared.Private_Part.Current_Source_Path_File;
+   end Current_Source_Path_File_Of;
+
    ---------------------------
    -- Delete_Temporary_File --
    ---------------------------
@@ -1029,6 +1052,46 @@ 
       Free_Units (Tree.Units_HT);
    end Reset;
 
+   -------------------------------------
+   -- Set_Current_Object_Path_File_Of --
+   -------------------------------------
+
+   procedure Set_Current_Object_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access;
+      To     : Path_Name_Type)
+   is
+   begin
+      Shared.Private_Part.Current_Object_Path_File := To;
+   end Set_Current_Object_Path_File_Of;
+
+   -------------------------------------
+   -- Set_Current_Source_Path_File_Of --
+   -------------------------------------
+
+   procedure Set_Current_Source_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access;
+      To     : Path_Name_Type)
+   is
+   begin
+      Shared.Private_Part.Current_Source_Path_File := To;
+   end Set_Current_Source_Path_File_Of;
+
+   -----------------------
+   -- Set_Path_File_Var --
+   -----------------------
+
+   procedure Set_Path_File_Var (Name : String; Value : String) is
+      Host_Spec : String_Access := To_Host_File_Spec (Value);
+   begin
+      if Host_Spec = null then
+         Prj.Com.Fail
+           ("could not convert file name """ & Value & """ to host spec");
+      else
+         Setenv (Name, Host_Spec.all);
+         Free (Host_Spec);
+      end if;
+   end Set_Path_File_Var;
+
    -------------------
    -- Switches_Name --
    -------------------
Index: prj.ads
===================================================================
--- prj.ads	(revision 178156)
+++ prj.ads	(working copy)
@@ -1595,6 +1595,29 @@ 
      (Source_File_Name : File_Name_Type) return File_Name_Type;
    --  Returns the switches file name corresponding to a source file name
 
+   procedure Set_Path_File_Var (Name : String; Value : String);
+   --  Call Setenv, after calling To_Host_File_Spec
+
+   function Current_Source_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access)
+      return Path_Name_Type;
+   --  Get the current include path file name
+
+   procedure Set_Current_Source_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access;
+      To     : Path_Name_Type);
+   --  Record the current include path file name
+
+   function Current_Object_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access)
+      return Path_Name_Type;
+   --  Get the current object path file name
+
+   procedure Set_Current_Object_Path_File_Of
+     (Shared : Shared_Project_Tree_Data_Access;
+      To     : Path_Name_Type);
+   --  Record the current object path file name
+
    -----------
    -- Flags --
    -----------
@@ -1676,7 +1699,7 @@ 
    --  resolved will simply be ignored. However, in such a case, the flag
    --  Incomplete_With in the project tree will be set to True.
    --  This is meant for use by tools so that they can properly set the
-   --  project path in such a case:
+   --  project path in such a case:Shared_
    --       * no "gnatls" found (so no default project path)
    --       * user project sets Project.IDE'gnatls attribute to a cross gnatls
    --       * user project also includes a "with" that can only be resolved
Index: makeutl.adb
===================================================================
--- makeutl.adb	(revision 178155)
+++ makeutl.adb	(working copy)
@@ -32,12 +32,11 @@ 
 with Osint;    use Osint;
 with Output;   use Output;
 with Opt;      use Opt;
+with Prj.Com;
 with Prj.Err;
 with Prj.Ext;
 with Prj.Util; use Prj.Util;
 with Sinput.P;
-with Snames;   use Snames;
-with Table;
 with Tempdir;
 
 with Ada.Command_Line;           use Ada.Command_Line;
@@ -681,6 +680,118 @@ 
       return False;
    end File_Not_A_Source_Of;
 
+   ---------------------
+   -- Get_Directories --
+   ---------------------
+
+   procedure Get_Directories
+     (Project_Tree : Project_Tree_Ref;
+      For_Project  : Project_Id;
+      Activity     : Activity_Type;
+      Languages    : Name_Ids)
+   is
+
+      procedure Recursive_Add
+        (Project  : Project_Id;
+         Tree     : Project_Tree_Ref;
+         Extended : in out Boolean);
+      --  Add all the source directories of a project to the path only if
+      --  this project has not been visited. Calls itself recursively for
+      --  projects being extended, and imported projects.
+
+      procedure Add_Dir (Value : Path_Name_Type);
+      --  Add directory Value in table Directories, if it is defined and not
+      --  already there.
+
+      -------------
+      -- Add_Dir --
+      -------------
+
+      procedure Add_Dir (Value : Path_Name_Type) is
+         Add_It : Boolean := True;
+
+      begin
+         if Value /= No_Path then
+            for Index in 1 .. Directories.Last loop
+               if Directories.Table (Index) = Value then
+                  Add_It := False;
+                  exit;
+               end if;
+            end loop;
+
+            if Add_It then
+               Directories.Increment_Last;
+               Directories.Table (Directories.Last) := Value;
+            end if;
+         end if;
+      end Add_Dir;
+
+      -------------------
+      -- Recursive_Add --
+      -------------------
+
+      procedure Recursive_Add
+        (Project  : Project_Id;
+         Tree     : Project_Tree_Ref;
+         Extended : in out Boolean)
+      is
+         Current   : String_List_Id;
+         Dir       : String_Element;
+         OK        : Boolean := False;
+         Lang_Proc : Language_Ptr := Project.Languages;
+      begin
+         --  Add to path all directories of this project
+
+         if Activity = Compilation then
+            Lang_Loop :
+            while Lang_Proc /= No_Language_Index loop
+               for J in Languages'Range loop
+                  OK := Lang_Proc.Name = Languages (J);
+                  exit Lang_Loop when OK;
+               end loop;
+
+               Lang_Proc := Lang_Proc.Next;
+            end loop Lang_Loop;
+
+            if OK then
+               Current := Project.Source_Dirs;
+
+               while Current /= Nil_String loop
+                  Dir := Tree.Shared.String_Elements.Table (Current);
+                  Add_Dir (Path_Name_Type (Dir.Value));
+                  Current := Dir.Next;
+               end loop;
+            end if;
+
+         elsif Project.Library then
+            if Activity = SAL_Binding and then Extended then
+               Add_Dir (Project.Object_Directory.Display_Name);
+
+            else
+               Add_Dir (Project.Library_ALI_Dir.Display_Name);
+            end if;
+
+         else
+            Add_Dir (Project.Object_Directory.Display_Name);
+         end if;
+
+         if Project.Extends = No_Project then
+            Extended := False;
+         end if;
+      end Recursive_Add;
+
+      procedure For_All_Projects is
+        new For_Every_Project_Imported (Boolean, Recursive_Add);
+
+      Extended : Boolean := True;
+
+      --  Start of processing for Get_Directories
+
+   begin
+      Directories.Init;
+      For_All_Projects (For_Project, Project_Tree, Extended);
+   end Get_Directories;
+
    ------------------
    -- Get_Switches --
    ------------------
@@ -3208,4 +3319,33 @@ 
       end if;
    end Compute_Builder_Switches;
 
+   ---------------------
+   -- Write_Path_File --
+   ---------------------
+
+   procedure Write_Path_File (FD : File_Descriptor) is
+      Last : Natural;
+      Status : Boolean;
+   begin
+      Name_Len := 0;
+
+      for Index in Directories.First .. Directories.Last loop
+         Add_Str_To_Name_Buffer (Get_Name_String (Directories.Table (Index)));
+         Add_Char_To_Name_Buffer (ASCII.LF);
+      end loop;
+
+      Last := Write (FD, Name_Buffer (1)'Address, Name_Len);
+
+      if Last = Name_Len then
+         Close (FD, Status);
+
+      else
+         Status := False;
+      end if;
+
+      if not Status then
+         Prj.Com.Fail ("could not write temporary file");
+      end if;
+   end Write_Path_File;
+
 end Makeutl;
Index: makeutl.ads
===================================================================
--- makeutl.ads	(revision 178155)
+++ makeutl.ads	(working copy)
@@ -33,6 +33,8 @@ 
 with Osint;
 with Prj;      use Prj;
 with Prj.Tree;
+with Snames;   use Snames;
+with Table;
 with Types;    use Types;
 
 with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -65,6 +67,16 @@ 
    Create_Map_File_Switch : constant String := "--create-map-file";
    --  Switch to create a map file when an executable is linked
 
+   package Directories is new Table.Table
+     (Table_Component_Type => Path_Name_Type,
+      Table_Index_Type     => Integer,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Makegpr.Directories");
+   --  Table of all the source or object directories, filled up by
+   --  Get_Directories.
+
    procedure Add
      (Option : String_Access;
       To     : in out String_List_Access;
@@ -159,6 +171,30 @@ 
    --  is printed last. Both N1 and N2 are printed in quotation marks. The two
    --  forms differ only in taking Name_Id or File_name_Type arguments.
 
+   type Name_Ids is array (Positive range <>) of Name_Id;
+   No_Names : constant Name_Ids := (1 .. 0 => No_Name);
+   --  Name_Ids is used for list of language names in procedure Get_Directories
+   --  below.
+   Ada_Only : constant Name_Ids := (1 => Name_Ada);
+   --  Used to invoke Get_Directories in gnatmake
+
+   type Activity_Type is (Compilation, Executable_Binding, SAL_Binding);
+
+   procedure Get_Directories
+     (Project_Tree : Project_Tree_Ref;
+      For_Project  : Project_Id;
+      Activity     : Activity_Type;
+      Languages    : Name_Ids);
+   --  Put in table Directories the source (when Sources is True) or
+   --  object/library (when Sources is False) directories of project
+   --  For_Project and of all the project it imports directly or indirectly.
+   --  The source directories of imported projects are only included if one
+   --  of the declared languages is in the list Languages.
+
+   procedure Write_Path_File (FD : File_Descriptor);
+   --  Write in the specified open path file the directories in table
+   --  Directories, then closed the path file.
+
    procedure Get_Switches
      (Source       : Source_Id;
       Pkg_Name     : Name_Id;
Index: prj-env.adb
===================================================================
--- prj-env.adb	(revision 178155)
+++ prj-env.adb	(working copy)
@@ -102,9 +102,6 @@ 
    --  Add Object_Dir to object path table. Make sure it is not duplicate
    --  and it is the last one in the current table.
 
-   procedure Set_Path_File_Var (Name : String; Value : String);
-   --  Call Setenv, after calling To_Host_File_Spec
-
    ----------------------
    -- Ada_Include_Path --
    ----------------------
@@ -1776,22 +1773,6 @@ 
       Free (Buffer);
    end Set_Ada_Paths;
 
-   -----------------------
-   -- Set_Path_File_Var --
-   -----------------------
-
-   procedure Set_Path_File_Var (Name : String; Value : String) is
-      Host_Spec : String_Access := To_Host_File_Spec (Value);
-   begin
-      if Host_Spec = null then
-         Prj.Com.Fail
-           ("could not convert file name """ & Value & """ to host spec");
-      else
-         Setenv (Name, Host_Spec.all);
-         Free (Host_Spec);
-      end if;
-   end Set_Path_File_Var;
-
    ---------------------
    -- Add_Directories --
    ---------------------