diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a31639b95a7..9e76cbb5f68 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2014-10-31 Vincent Celier + + * prj-conf.adb (Look_For_Project_Paths): New procedure + (Parse_Project_And_Apply_Config): Initially, parse the project + files ignoring missing withs. If there are missing withs, extend + the project path with directories rooted at the compiler roots, + including directories rooted at the runtime roots, if there are + non default runtimes, in the PATH orser. + * prj-env.adb (Initialize_Default_Project_Path): Do not add + any directory from the prefix if the target is "-". + * prj-part.adb (Parse): Initialize the tables, as Parse may be + call several times by gprbuild. + * prj.adb (Update_Ignore_Missing_With): New procedure. + +2014-10-31 Ed Schonberg + + * sem_aux.adb (First_Stored_Discriminant, + Has_Completely_Hidden_Discriminant): When scanning the list of + discriminants to locate possibly hidden (inherited) discriminants, + ignore itypes that may appear in the entity list, when an access + discriminants is constrained by an access attribute reference. + +2014-10-31 Javier Miranda + + * freeze.adb (Freeze_Record_Type): Add missing + check to verify that all the primitives of an interface type + are abstract or null procedures. + +2014-10-31 Vincent Celier + + * s-os_lib.adb, s-os_lib.ads: New function Non_Blocking_Spawn that + redirects standard output and standard error to two different files. + +2014-10-31 Bob Duff + + * makeutl.ads: Minor comment fix. + +2014-10-31 Arnaud Charlet + + * system-linux-x86_64.ads, system-mingw-x86_64.ads (Word_Size, + Memory_Size): Use Standard'Word_Size so that the value can be changed + via a target configuration file. + 2014-10-31 Eric Botcazou * exp_ch4.adb: Minor tweak. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index caef71f9197..e20aebb1df2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4004,6 +4004,47 @@ package body Freeze is -- call to the Analyze_Freeze_Entity for the record type. end Check_Variant_Part; + + -- Check that all the primitives of an interface type are abstract + -- or null procedures. + + if Is_Interface (Rec) + and then not Error_Posted (Parent (Rec)) + then + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Rec)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if not Is_Abstract_Subprogram (Subp) + + -- Avoid reporting the error on inherited primitives + + and then Comes_From_Source (Subp) + then + Error_Msg_Name_1 := Chars (Subp); + + if Ekind (Subp) = E_Procedure then + if not Null_Present (Parent (Subp)) then + Error_Msg_N + ("interface procedure % must be abstract or null", + Parent (Subp)); + end if; + else + Error_Msg_N + ("interface function % must be abstract", + Parent (Subp)); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; end Freeze_Record_Type; ------------------------------- diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 04537090318..cf28b1ec1da 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -254,8 +254,8 @@ package Makeutl is -- file. This checks various attributes to see if there are file specific -- switches, or else defaults on the switches for the corresponding -- language. Is_Default is set to False if there were file-specific - -- switches Source_File can be set to No_File to force retrieval of the - -- default switches. If Test_Without_Suffix is True, and there is no " for + -- switches. Source_File can be set to No_File to force retrieval of the + -- default switches. If Test_Without_Suffix is True, and there is no "for -- Switches(Source_File) use", then this procedure also tests without the -- extension of the filename. If Test_Without_Suffix is True and -- Check_ALI_Suffix is True, then we also replace the file extension with diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 1afdb2ce55a..fe6cb60b381 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -53,6 +53,32 @@ package body Prj.Conf is Gprconfig_Name : constant String := "gprconfig"; + Warn_For_RTS : Boolean := True; + -- Set to False when gprbuild parse again the project files, to avoid + -- an incorrect warning. + + type Runtime_Root_Data; + type Runtime_Root_Ptr is access Runtime_Root_Data; + type Runtime_Root_Data is record + Root : String_Access; + Next : Runtime_Root_Ptr; + end record; + -- Data for a runtime root to be used when adding directories to the + -- project path. + + type Compiler_Root_Data; + type Compiler_Root_Ptr is access Compiler_Root_Data; + type Compiler_Root_Data is record + Root : String_Access; + Runtimes : Runtime_Root_Ptr; + Next : Compiler_Root_Ptr; + end record; + -- Data for a compiler root to be used when adding directories to the + -- project path. + + First_Compiler_Root : Compiler_Root_Ptr := null; + -- Head of the list of compiler roots + package RTS_Languages is new GNAT.HTable.Simple_HTable (Header_Num => Prj.Header_Num, Element => Name_Id, @@ -98,6 +124,21 @@ package body Prj.Conf is -- projects, so that when the second phase of the processing is performed -- these attributes are automatically taken into account. + type State is (No_State); + + procedure Look_For_Project_Paths + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out State); + -- Check the compilers in the Project and add record them in the list + -- rooted at First_Compiler_Root, with their runtimes, if they are not + -- already in the list. + + procedure Update_Project_Path is new + For_Every_Project_Imported + (State => State, + Action => Look_For_Project_Paths); + ------------------------------------ -- Add_Default_GNAT_Naming_Scheme -- ------------------------------------ @@ -1448,7 +1489,8 @@ package body Prj.Conf is -- If the config file is not auto-generated, warn if there is any --RTS -- switch, but not when the config file is generated in memory. - elsif RTS_Languages.Get_First /= No_Name + elsif Warn_For_RTS + and then RTS_Languages.Get_First /= No_Name and then Opt.Warning_Mode /= Opt.Suppress and then On_Load_Config = null then @@ -1558,11 +1600,36 @@ package body Prj.Conf is On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null) is Success : Boolean := False; - Try_Again : Boolean := True; + Target_Try_Again : Boolean := True; + Config_Try_Again : Boolean; + + S : State := No_State; + + Conf_File_Name : String_Access := new String'(Config_File_Name); + + procedure Add_Directory (Dir : String); + -- Add a directory at the end of the Project Path + + ------------------- + -- Add_Directory -- + ------------------- + + procedure Add_Directory (Dir : String) is + begin + if Opt.Verbose_Mode then + Write_Line (" Adding directory """ & Dir & """"); + end if; + + Prj.Env.Add_Directories (Env.Project_Path, Dir); + end Add_Directory; begin pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); + -- Start with ignoring missing withed projects + + Update_Ignore_Missing_With (Env.Flags, True); + -- Record Target_Value and Target_Origin. if Target_Name = "" then @@ -1630,10 +1697,10 @@ package body Prj.Conf is and then Get_Name_String (Variable.Value) /= Opt.Target_Value.all then - if Try_Again then + if Target_Try_Again then Opt.Target_Value := new String'(Get_Name_String (Variable.Value)); - Try_Again := False; + Target_Try_Again := False; goto Parse_Again; else @@ -1643,13 +1710,18 @@ package body Prj.Conf is end if; end if; end; - end if; + -- If there are missing withed projects, the projects will be parsed + -- again after the project path is extended with directories rooted + -- at the compiler roots. + + Config_Try_Again := Project_Node_Tree.Incomplete_With; + Process_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, - Config_File_Name => Config_File_Name, + Config_File_Name => Conf_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, @@ -1663,6 +1735,194 @@ package body Prj.Conf is On_Load_Config => On_Load_Config, On_New_Tree_Loaded => On_New_Tree_Loaded, Do_Phase_1 => Opt.Target_Origin = Specified); + + -- Exit if there was an error. Otherwise, if Config_Try_Again is True, + -- update the project path and try again. + + if Main_Project /= No_Project and then Config_Try_Again then + Update_Ignore_Missing_With (Env.Flags, False); + + if Config_File_Path /= null then + Conf_File_Name := new String'(Simple_Name (Config_File_Path.all)); + end if; + + -- For the second time the project files are parsed, the warning for + -- --RTS= being only taken into account in auto-configuration are + -- suppressed, as we are no longer in auto-configuration. + + Warn_For_RTS := False; + + -- Add the default directories corresponding to the compilers + + Update_Project_Path + (By => Main_Project, + Tree => Project_Tree, + With_State => S, + Include_Aggregated => True, + Imported_First => False); + + declare + Compiler_Root : Compiler_Root_Ptr; + Prefix : String_Access; + Runtime_Root : Runtime_Root_Ptr; + Path_Value : constant String_Access := Getenv ("PATH"); + + begin + if Opt.Verbose_Mode then + Write_Line ("Setting the default project search directories"); + + if Prj.Current_Verbosity = High then + if Path_Value = null or else Path_Value'Length = 0 then + Write_Line ("No environment variable PATH"); + + else + Write_Line ("PATH ="); + Write_Line (" " & Path_Value.all); + end if; + end if; + end if; + + -- Reorder the compiler roots in the PATH order + + if First_Compiler_Root /= null + and then First_Compiler_Root.Next /= null + then + declare + Pred : Compiler_Root_Ptr; + First_New_Comp : Compiler_Root_Ptr := null; + New_Comp : Compiler_Root_Ptr := null; + First : Positive := Path_Value'First; + Last : Positive; + Path_Last : Positive; + begin + while First <= Path_Value'Last loop + Last := First; + + if Path_Value (First) /= Path_Separator then + while Last < Path_Value'Last + and then Path_Value (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Path_Last := Last; + while Path_Last > First + and then + Path_Value (Path_Last) = Directory_Separator + loop + Path_Last := Path_Last - 1; + end loop; + + if Path_Last > First + 4 + and then + Path_Value (Path_Last - 2 .. Path_Last) = "bin" + and then + Path_Value (Path_Last - 3) = Directory_Separator + then + Path_Last := Path_Last - 4; + Pred := null; + Compiler_Root := First_Compiler_Root; + while Compiler_Root /= null + and then Compiler_Root.Root.all /= + Path_Value (First .. Path_Last) + loop + Pred := Compiler_Root; + Compiler_Root := Compiler_Root.Next; + end loop; + + if Compiler_Root /= null then + if Pred = null then + First_Compiler_Root := + First_Compiler_Root.Next; + else + Pred.Next := Compiler_Root.Next; + end if; + + if First_New_Comp = null then + First_New_Comp := Compiler_Root; + else + New_Comp.Next := Compiler_Root; + end if; + + New_Comp := Compiler_Root; + New_Comp.Next := null; + end if; + end if; + end if; + + First := Last + 1; + end loop; + + if First_New_Comp /= null then + New_Comp.Next := First_Compiler_Root; + First_Compiler_Root := First_New_Comp; + end if; + end; + end if; + + -- Now that the compiler roots are in a correct order, add the + -- directories corresponding to these compiler roots in the + -- project path. + + Compiler_Root := First_Compiler_Root; + while Compiler_Root /= null loop + Prefix := Compiler_Root.Root; + + Runtime_Root := Compiler_Root.Runtimes; + while Runtime_Root /= null loop + Add_Directory + (Runtime_Root.Root.all & + Directory_Separator & + "lib" & + Directory_Separator & + "gnat"); + Add_Directory + (Runtime_Root.Root.all & + Directory_Separator & + "share" & + Directory_Separator & + "gpr"); + Runtime_Root := Runtime_Root.Next; + end loop; + + Add_Directory + (Prefix.all & + Directory_Separator & + Opt.Target_Value.all & + Directory_Separator & + "lib" & + Directory_Separator & + "gnat"); + Add_Directory + (Prefix.all & + Directory_Separator & + Opt.Target_Value.all & + Directory_Separator & + "share" & + Directory_Separator & + "gpr"); + Add_Directory + (Prefix.all & + Directory_Separator & + "share" & + Directory_Separator & + "gpr"); + Add_Directory + (Prefix.all & + Directory_Separator & + "lib" & + Directory_Separator & + "gnat"); + Compiler_Root := Compiler_Root.Next; + end loop; + end; + + -- And parse again the project files. There will be no missing + -- withed projects, as Ignore_Missing_With is set to False in + -- the environment flags, so there is no risk of endless loop here. + + goto Parse_Again; + end if; end Parse_Project_And_Apply_Config; -------------------------------------- @@ -1886,4 +2146,112 @@ package body Prj.Conf is RTS_Languages.Set (Language, Name_Find); end Set_Runtime_For; + ---------------------------- + -- Look_For_Project_Paths -- + ---------------------------- + + procedure Look_For_Project_Paths + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out State) + is + Lang_Id : Language_Ptr; + Compiler_Root : Compiler_Root_Ptr; + Runtime_Root : Runtime_Root_Ptr; + Comp_Driver : String_Access; + Comp_Dir : String_Access; + Prefix : String_Access; + + pragma Unreferenced (Tree); + + begin + With_State := No_State; + + Lang_Id := Project.Languages; + while Lang_Id /= No_Language_Index loop + if Lang_Id.Config.Compiler_Driver /= No_File then + Comp_Driver := + new String' + (Get_Name_String (Lang_Id.Config.Compiler_Driver)); + + -- Get the absolute path of the compiler driver + + if not Is_Absolute_Path (Comp_Driver.all) then + Comp_Driver := Locate_Exec_On_Path (Comp_Driver.all); + end if; + + if Comp_Driver /= null and then Comp_Driver'Length > 0 then + Comp_Dir := + new String' + (Containing_Directory (Comp_Driver.all)); + + -- Consider only the compiler drivers that are in "bin" + -- subdirectories. + + if Simple_Name (Comp_Dir.all) = "bin" then + Prefix := + new String'(Containing_Directory (Comp_Dir.all)); + + -- Check if the compiler root is already in the list. If it + -- is not, add it to the list. + + Compiler_Root := First_Compiler_Root; + while Compiler_Root /= null loop + exit when Prefix.all = Compiler_Root.Root.all; + Compiler_Root := Compiler_Root.Next; + end loop; + + if Compiler_Root = null then + First_Compiler_Root := + new Compiler_Root_Data' + (Root => Prefix, + Runtimes => null, + Next => First_Compiler_Root); + Compiler_Root := First_Compiler_Root; + end if; + + -- If there is a runtime for this compiler, check if it is + -- recorded with the compiler root. If it is not, record + -- the runtime. + + declare + Runtime : constant String := + Runtime_Name_For (Lang_Id.Name); + Root : String_Access; + begin + if Runtime'Length > 0 then + if Is_Absolute_Path (Runtime) then + Root := new String'(Runtime); + + else + Root := + new String' + (Prefix.all & + Directory_Separator & + Opt.Target_Value.all & + Directory_Separator & + Runtime); + end if; + + Runtime_Root := Compiler_Root.Runtimes; + while Runtime_Root /= null loop + exit when Root.all = Runtime_Root.Root.all; + Runtime_Root := Runtime_Root.Next; + end loop; + + if Runtime_Root = null then + Compiler_Root.Runtimes := + new Runtime_Root_Data' + (Root => Root, + Next => Compiler_Root.Runtimes); + end if; + end if; + end; + end if; + end if; + end if; + + Lang_Id := Lang_Id.Next; + end loop; + end Look_For_Project_Paths; end Prj.Conf; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index b6bb25fcbf8..7dbb4ce7c8c 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1876,7 +1876,7 @@ package body Prj.Env is (Self : in out Project_Search_Path; Target_Name : String) is - Add_Default_Dir : Boolean := True; + Add_Default_Dir : Boolean := Target_Name /= "-"; First : Positive; Last : Positive; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 08f2b400f6b..f070a75fce3 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -175,8 +175,10 @@ package Prj.Env is Target_Name : String); -- Initialize Self. It will then contain the default project path on the -- given target (including directories specified by the environment - -- variables ADA_PROJECT_PATH and GPR_PROJECT_PATH). This does nothing if - -- Self has already been initialized. + -- variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and ADA_PROJECT_PATH). + -- If one of the directory or Target_Name is "-", then the path contains + -- only those directories specified by the environment variables (except + -- "-"). This does nothing if Self has already been initialized. procedure Copy (From : Project_Search_Path; To : out Project_Search_Path); -- Copy From into To diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 5f04158bebf..34b13bc1e80 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -553,6 +553,8 @@ package body Prj.Part is begin In_Tree.Incomplete_With := False; + Project_Stack.Init; + Tree_Private_Part.Projects_Htable.Reset (In_Tree.Projects_HT); if not Is_Initialized (Env.Project_Path) then Prj.Env.Initialize_Default_Project_Path diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 88196e10f41..8a267cf476f 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -2147,6 +2147,17 @@ package body Prj is (Root_Project, Root_Tree, Project_Context'(False, False)); end For_Project_And_Aggregated_Context; + -------------------------------- + -- Update_Ignore_Missing_With -- + -------------------------------- + + procedure Update_Ignore_Missing_With + (Flags : in out Processing_Flags; Value : Boolean) + is + begin + Flags.Ignore_Missing_With := Value; + end Update_Ignore_Missing_With; + -- Package initialization for Prj begin diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 804d88aa210..4ba3fac3bca 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1893,6 +1893,10 @@ package Prj is -- * user project also includes a "with" that can only be resolved -- once we have found the gnatls + procedure Update_Ignore_Missing_With + (Flags : in out Processing_Flags; Value : Boolean); + -- Update the value of component Ignore_Missing_With in Flags with Value + Gprbuild_Flags : constant Processing_Flags; Gprinstall_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 5f70faba0ab..46fdd006784 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1698,6 +1698,54 @@ package body System.OS_Lib is end if; end Non_Blocking_Spawn; + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Stdout_File : String; + Stderr_File : String) return Process_Id + is + Stdout_FD : constant File_Descriptor := + Create_Output_Text_File (Stdout_File); + Stderr_FD : constant File_Descriptor := + Create_Output_Text_File (Stderr_File); + + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; + + Result : Process_Id; + + begin + -- Do not attempt to spawn if the output files could not be created + + if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and error to the specified files + + Saved_Output := Dup (Standout); + Dup2 (Stdout_FD, Standout); + + Saved_Error := Dup (Standerr); + Dup2 (Stderr_FD, Standerr); + + -- Spawn the program + + Result := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + Close (Saved_Error); + + return Result; + end Non_Blocking_Spawn; + ------------------------- -- Normalize_Arguments -- ------------------------- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 2a24ca29d62..d285fd4cb07 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -856,6 +856,15 @@ package System.OS_Lib is -- This function will always return Invalid_Pid under VxWorks, since there -- is no notion of executables under this OS. + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Stdout_File : String; + Stderr_File : String) return Process_Id; + -- Similar to the procedure above, but saves the standard output of the + -- command to a file with the name Stdout_File and the standard output + -- of the command to a file with the name Stderr_File. + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); -- Wait for the completion of any of the processes created by previous -- calls to Non_Blocking_Spawn. The caller will be suspended until one of diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4b251e31c51..68104b906ff 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -282,6 +282,8 @@ package body Sem_Aux is (Typ : Entity_Id) return Boolean; -- Scans the Discriminants to see whether any are Completely_Hidden -- (the mechanism for describing non-specified stored discriminants) + -- Note that the entity list for the type may contain anonymous access + -- types created by expressions that constrain access discriminants. ---------------------------------------- -- Has_Completely_Hidden_Discriminant -- @@ -296,8 +298,17 @@ package body Sem_Aux is pragma Assert (Ekind (Typ) = E_Discriminant); Ent := Typ; - while Present (Ent) and then Ekind (Ent) = E_Discriminant loop - if Is_Completely_Hidden (Ent) then + while Present (Ent) loop + + -- Skip anonymous types that may be created by expressions + -- used as discriminant constraints on inherited discriminants. + + if Is_Itype (Ent) then + null; + + elsif Ekind (Ent) = E_Discriminant + and then Is_Completely_Hidden (Ent) + then return True; end if; @@ -322,7 +333,8 @@ package body Sem_Aux is if Has_Completely_Hidden_Discriminant (Ent) then while Present (Ent) loop - exit when Is_Completely_Hidden (Ent); + exit when Ekind (Ent) = E_Discriminant + and then Is_Completely_Hidden (Ent); Ent := Next_Entity (Ent); end loop; end if; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads index 2874376f002..3103cf781d9 100644 --- a/gcc/ada/system-linux-x86_64.ads +++ b/gcc/ada/system-linux-x86_64.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison diff --git a/gcc/ada/system-mingw-x86_64.ads b/gcc/ada/system-mingw-x86_64.ads index 7b73968d10c..865bcd6b161 100644 --- a/gcc/ada/system-mingw-x86_64.ads +++ b/gcc/ada/system-mingw-x86_64.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison