* get_scos.adb: When reading a P statement SCO without a pragma name
(from an older ALI file), ensure that the Pragma_Name component is set
to Unknown_Pragma (not left uninitialized).
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
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): For an assignment to a
packed entity, use a bit-field assignment only if there is no change of
representation.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178177
138bc75d-0d04-0410-961f-
82ee72b054a4
2011-08-29 Thomas Quinot <quinot@adacore.com>
+ * get_scos.adb: When reading a P statement SCO without a pragma name
+ (from an older ALI file), ensure that the Pragma_Name component is set
+ to Unknown_Pragma (not left uninitialized).
+
+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
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement): For an assignment to a
+ packed entity, use a bit-field assignment only if there is no change of
+ representation.
+
+2011-08-29 Thomas Quinot <quinot@adacore.com>
+
* rtsfind.ads, exp_ch3.adb (In_Runtime): Minor code improvement, use
Is_RTU instead of using Chars comparisons.
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Crep : constant Boolean := Change_Of_Representation (N);
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
-- Skip discriminant check if change of representation. Will be
-- done when the change of representation is expanded out.
- if not Change_Of_Representation (N) then
+ if not Crep then
Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
end if;
-- Skip discriminant check if change of representation. Will be
-- done when the change of representation is expanded out.
- if not Change_Of_Representation (N) then
+ if not Crep then
Apply_Discriminant_Check (Rhs, Etype (Lhs));
end if;
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
- -- Case of assignment to a bit packed array element
+ -- Case of assignment to a bit packed array element. If there is a
+ -- change of representation this must be expanded into components,
+ -- otherwise this is a bit-field assignment.
if Nkind (Lhs) = N_Indexed_Component
and then Is_Bit_Packed_Array (Etype (Prefix (Lhs)))
+ and then not Crep
then
Expand_Bit_Packed_Element_Set (N);
return;
Typ := ' ';
else
Skipc;
- if Typ = 'P' and then Nextc not in '1' .. '9' then
- N := 1;
- loop
- Buf (N) := Getc;
- exit when Nextc = ':';
- N := N + 1;
- end loop;
-
- begin
- Pid := Pragma_Id'Value (Buf (1 .. N));
- exception
- when Constraint_Error =>
- Pid := Unknown_Pragma;
- end;
-
- Skipc;
+ if Typ = 'P' then
+ Pid := Unknown_Pragma;
+
+ if Nextc not in '1' .. '9' then
+ N := 1;
+ loop
+ Buf (N) := Getc;
+ exit when Nextc = ':';
+ N := N + 1;
+ end loop;
+ Skipc;
+
+ begin
+ Pid := Pragma_Id'Value (Buf (1 .. N));
+ exception
+ when Constraint_Error =>
+
+ -- Pid remains set to Unknown_Pragma
+
+ null;
+ end;
+ end if;
end if;
end if;
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;
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 --
------------------
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;
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;
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;
-- 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;
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;
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
-- 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
-- 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 --
----------------------
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 --
---------------------
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;
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 --
---------------------------
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 --
-------------------
(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 --
-----------
-- 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
OSDN Git Service
