From 94fb7608441bd960315df71ce953d9a88a9f74a3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 11:28:10 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Thomas Quinot * 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 * 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 * 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. From-SVN: r178177 --- gcc/ada/ChangeLog | 36 +++++++++++++ gcc/ada/exp_ch5.adb | 10 ++-- gcc/ada/get_scos.adb | 38 ++++++++------ gcc/ada/makeutl.adb | 144 ++++++++++++++++++++++++++++++++++++++++++++++++++- gcc/ada/makeutl.ads | 36 +++++++++++++ gcc/ada/mlib-prj.adb | 58 +++++++++++++++++++-- gcc/ada/prj-env.adb | 19 ------- gcc/ada/prj.adb | 63 ++++++++++++++++++++++ gcc/ada/prj.ads | 25 ++++++++- 9 files changed, 384 insertions(+), 45 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 17845b4..fffc645 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,41 @@ 2011-08-29 Thomas Quinot + * 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 + + * 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 + + * 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 + * rtsfind.ads, exp_ch3.adb (In_Runtime): Minor code improvement, use Is_RTU instead of using Chars comparisons. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 165f9ae..7dd2800 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1511,6 +1511,7 @@ package body Exp_Ch5 is 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)); @@ -1780,7 +1781,7 @@ package body Exp_Ch5 is -- 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; @@ -1830,7 +1831,7 @@ package body Exp_Ch5 is -- 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; @@ -1883,10 +1884,13 @@ package body Exp_Ch5 is 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; diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 8fc4dfc..8ad5a44 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -293,22 +293,28 @@ begin 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; diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 0286267..b347497 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -32,12 +32,11 @@ with Hostparm; 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 @@ package body Makeutl is 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 @@ package body Makeutl is 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; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index f3ac998..f7eadac 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -33,6 +33,8 @@ with Opt; 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 @@ package Makeutl is 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 @@ package Makeutl is -- 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; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 9ac12e7..b01ad9d 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -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 @@ package body MLib.Prj is 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,10 +1048,56 @@ package body MLib.Prj is -- 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 diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 0c66142..40f4ae5 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -102,9 +102,6 @@ package body Prj.Env is -- 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 @@ package body Prj.Env is 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 -- --------------------- diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 133fca5..e69d529 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -27,6 +27,7 @@ with Debug; 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 @@ package body Prj is 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 @@ package body Prj is 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 -- ------------------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index b075235..131a45b 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1595,6 +1595,29 @@ package Prj is (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 @@ package Prj is -- 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 -- 2.7.4