From e2c7aa50fe37a9ac2d730c26e6aac06aea885431 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 7 Jan 2015 10:22:51 +0000 Subject: [PATCH] 2015-01-07 Robert Dewar * s-taprop-linux.adb, clean.adb: Minor reformatting. 2015-01-07 Arnaud Charlet * s-tassta.adb: Relax some overzealous assertions. 2015-01-07 Ed Schonberg * sem_ch6.adb (Analyze_Return_Type): An call that returns a limited view of a type is legal when context is a thunk generated for operation inherited from an interface. * exp_ch6.adb (Expand_Simple_Function_Return): If context is a thunk and return type is an incomplete type do not continue expansion; thunk will be fully elaborated when generating code. 2015-01-07 Doug Rupp * s-osinte-mingw.ads (LARGE_INTEGR): New subtype. (QueryPerformanceFrequency): New imported procedure. * s-taprop-mingw.adb (RT_Resolution): Call above and return resolution vice a hardcoded value. * s-taprop-solaris.adb (RT_Resolution): Call clock_getres and return resolution vice a hardcoded value. * s-linux-android.ads (clockid_t): New subtype. * s-osinte-aix.ads (clock_getres): New imported subprogram. * s-osinte-android.ads (clock_getres): Likewise. * s-osinte-freebsd.ads (clock_getres): Likewise. * s-osinte-solaris-posix.ads (clock_getres): Likewise. * s-osinte-darwin.ads (clock_getres): New subprogram. * s-osinte-darwin.adb (clock_getres): New subprogram. * thread.c (__gnat_clock_get_res) [__APPLE__]: New function. * s-taprop-posix.adb (RT_Resolution): Call clock_getres to calculate resolution vice hard coded value. 2015-01-07 Ed Schonberg * exp_util.adb (Make_CW_Equivalent_Type): If root type is a limited view, use non-limited view when available to create equivalent record type. 2015-01-07 Vincent Celier * gnatcmd.adb: Remove command Sync and any data and processing related to this command. Remove project processing for gnatstack. * prj-attr.adb: Remove package Synchonize and its attributes. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219291 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 48 +++ gcc/ada/clean.adb | 18 +- gcc/ada/exp_ch6.adb | 8 + gcc/ada/exp_util.adb | 10 + gcc/ada/gnatcmd.adb | 742 ++++++------------------------------- gcc/ada/prj-attr.adb | 6 - gcc/ada/s-linux-android.ads | 1 + gcc/ada/s-osinte-aix.ads | 7 +- gcc/ada/s-osinte-android.ads | 5 + gcc/ada/s-osinte-darwin.adb | 30 ++ gcc/ada/s-osinte-darwin.ads | 6 +- gcc/ada/s-osinte-freebsd.ads | 7 +- gcc/ada/s-osinte-mingw.ads | 16 +- gcc/ada/s-osinte-solaris-posix.ads | 5 + gcc/ada/s-taprop-linux.adb | 1 + gcc/ada/s-taprop-mingw.adb | 4 +- gcc/ada/s-taprop-posix.adb | 9 +- gcc/ada/s-taprop-solaris.adb | 9 +- gcc/ada/s-tassta.adb | 10 +- gcc/ada/sem_ch6.adb | 8 + gcc/ada/thread.c | 34 +- 21 files changed, 331 insertions(+), 653 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 47a8051..a422194 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2015-01-07 Robert Dewar + + * s-taprop-linux.adb, clean.adb: Minor reformatting. + +2015-01-07 Arnaud Charlet + + * s-tassta.adb: Relax some overzealous assertions. + +2015-01-07 Ed Schonberg + + * sem_ch6.adb (Analyze_Return_Type): An call that returns a limited + view of a type is legal when context is a thunk generated for + operation inherited from an interface. + * exp_ch6.adb (Expand_Simple_Function_Return): If context is + a thunk and return type is an incomplete type do not continue + expansion; thunk will be fully elaborated when generating code. + +2015-01-07 Doug Rupp + + * s-osinte-mingw.ads (LARGE_INTEGR): New subtype. + (QueryPerformanceFrequency): New imported procedure. + * s-taprop-mingw.adb (RT_Resolution): Call above and return + resolution vice a hardcoded value. + * s-taprop-solaris.adb (RT_Resolution): Call clock_getres and return + resolution vice a hardcoded value. + * s-linux-android.ads (clockid_t): New subtype. + * s-osinte-aix.ads (clock_getres): New imported subprogram. + * s-osinte-android.ads (clock_getres): Likewise. + * s-osinte-freebsd.ads (clock_getres): Likewise. + * s-osinte-solaris-posix.ads (clock_getres): Likewise. + * s-osinte-darwin.ads (clock_getres): New subprogram. + * s-osinte-darwin.adb (clock_getres): New subprogram. + * thread.c (__gnat_clock_get_res) [__APPLE__]: New function. + * s-taprop-posix.adb (RT_Resolution): Call clock_getres to + calculate resolution vice hard coded value. + +2015-01-07 Ed Schonberg + + * exp_util.adb (Make_CW_Equivalent_Type): If root type is a + limited view, use non-limited view when available to create + equivalent record type. + +2015-01-07 Vincent Celier + + * gnatcmd.adb: Remove command Sync and any data and processing + related to this command. Remove project processing for gnatstack. + * prj-attr.adb: Remove package Synchonize and its attributes. + 2015-01-07 Vincent Celier * clean.adb: Minor error message change. diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index a9dede5..6a7f7fa 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -897,9 +897,9 @@ package body Clean is -- object directory. if (Unit.File_Names (Impl) /= null - and then - In_Extension_Chain - (Unit.File_Names (Impl).Project, Project)) + and then + In_Extension_Chain + (Unit.File_Names (Impl).Project, Project)) or else (Unit.File_Names (Spec) /= null and then @@ -1387,8 +1387,8 @@ package body Clean is if Project_File_Name /= null then Put_Line - ("warning: gnatclean -P is obsolete and will not be available " & - "in the next release; use gprclean instead."); + ("warning: gnatclean -P is obsolete and will not be available " + & "in the next release; use gprclean instead."); end if; -- A project file was specified by a -P switch @@ -1655,8 +1655,9 @@ package body Clean is case Arg (2) is when '-' => - if Arg'Length > Subdirs_Option'Length and then - Arg (1 .. Subdirs_Option'Length) = Subdirs_Option + if Arg'Length > Subdirs_Option'Length + and then + Arg (1 .. Subdirs_Option'Length) = Subdirs_Option then Subdirs := new String' @@ -1790,7 +1791,8 @@ package body Clean is declare Prj : constant String := Arg (3 .. Arg'Last); begin - if Prj'Length > 1 and then Prj (Prj'First) = '=' + if Prj'Length > 1 + and then Prj (Prj'First) = '=' then Project_File_Name := new String' diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c16fc49..e4d4588 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5914,6 +5914,14 @@ package body Exp_Ch6 is elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then null; + -- If the call is within a thunk and the type is a limited view, the + -- backend will eventually see the non-limited view of the type. + + elsif Is_Thunk (Current_Scope) + and then Is_Incomplete_Type (Exptyp) + then + return; + elsif not Requires_Transient_Scope (R_Type) then -- Mutable records with no variable length components are not diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 7bc6bc3..ed320cd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6074,6 +6074,16 @@ package body Exp_Util is or else Is_Constrained (Root_Typ) then Constr_Root := Root_Typ; + + -- At this point in the expansion, non-limited view of the type + -- must be available, otherwise the error will be reported later. + + if From_Limited_With (Constr_Root) + and then Present (Non_Limited_View (Constr_Root)) + then + Constr_Root := Non_Limited_View (Constr_Root); + end if; + else Constr_Root := Make_Temporary (Loc, 'R'); diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 7f9ca18..33c4be2 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -30,7 +30,6 @@ with Gnatvsn; with Makeutl; use Makeutl; with MLib.Tgt; use MLib.Tgt; with MLib.Utl; -with MLib.Fil; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; @@ -70,7 +69,6 @@ procedure GNATCmd is Clean, Compile, Check, - Sync, Elim, Find, Krunch, @@ -107,9 +105,6 @@ procedure GNATCmd is Current_Verbosity : Prj.Verbosity := Prj.Default; Tool_Package_Name : Name_Id := No_Name; - B_Start : constant String := "b~"; - -- Prefix of binder generated file - Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree @@ -174,20 +169,14 @@ procedure GNATCmd is Naming_String : constant SA := new String'("naming"); Binder_String : constant SA := new String'("binder"); - Compiler_String : constant SA := new String'("compiler"); - Synchronize_String : constant SA := new String'("synchronize"); Finder_String : constant SA := new String'("finder"); Linker_String : constant SA := new String'("linker"); Gnatls_String : constant SA := new String'("gnatls"); - Stack_String : constant SA := new String'("stack"); Xref_String : constant SA := new String'("cross_reference"); Packages_To_Check_By_Binder : constant String_List_Access := new String_List'((Naming_String, Binder_String)); - Packages_To_Check_By_Sync : constant String_List_Access := - new String_List'((Naming_String, Synchronize_String, Compiler_String)); - Packages_To_Check_By_Finder : constant String_List_Access := new String_List'((Naming_String, Finder_String)); @@ -197,9 +186,6 @@ procedure GNATCmd is Packages_To_Check_By_Gnatls : constant String_List_Access := new String_List'((Naming_String, Gnatls_String)); - Packages_To_Check_By_Stack : constant String_List_Access := - new String_List'((Naming_String, Stack_String)); - Packages_To_Check_By_Xref : constant String_List_Access := new String_List'((Naming_String, Xref_String)); @@ -222,9 +208,9 @@ procedure GNATCmd is -- The path of the working directory All_Projects : Boolean := False; - -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to - -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) - -- should be invoked for all sources of all projects. + -- Flag used for GNAT CHECK, GNAT PRETTY and GNAT METRIC to indicate that + -- the underlying tool (gnatcheck, gnatpp or gnatmetric) should be invoked + -- for all sources of all projects. type Command_Entry is record Cname : String_Access; @@ -265,11 +251,6 @@ procedure GNATCmd is Unixcmd => new String'("gnatcheck"), Unixsws => null), - Sync => - (Cname => new String'("SYNC"), - Unixcmd => new String'("gnatsync"), - Unixsws => null), - Elim => (Cname => new String'("ELIM"), Unixcmd => new String'("gnatelim"), @@ -345,22 +326,11 @@ procedure GNATCmd is -- Local Subprograms -- ----------------------- - procedure Add_To_Carg_Switches (Switch : String_Access); - -- Add a switch to the Carg_Switches table. If it is the first one, put the - -- switch "-cargs" at the beginning of the table. - procedure Check_Files; - -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a - -- project file is specified, without any file arguments and without a - -- switch -files=. If it is the case, invoke the GNAT tool with the proper - -- list of files, derived from the sources of the project. - - function Check_Project - (Project : Project_Id; - Root_Project : Project_Id) return Boolean; - -- Returns True if Project = Root_Project or if we want to consider all - -- sources of all projects. For GNAT METRIC, also returns True if Project - -- is extended by Root_Project. + -- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project file + -- is specified, without any file arguments and without a switch -files=. + -- If it is the case, invoke the GNAT tool with the proper list of files, + -- derived from the sources of the project. procedure Check_Relative_Executable (Name : in out String_Access); -- Check if an executable is specified as a relative path. If it is, and @@ -368,12 +338,6 @@ procedure GNATCmd is -- exec directory. This procedure is only used for GNAT LINK when a project -- file is specified. - function Configuration_Pragmas_File return Path_Name_Type; - -- Return an argument, if there is a configuration pragmas file to be - -- specified for Project, otherwise return No_Name. Used for gnatstub - -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric - -- (GNAT METRIC). - procedure Delete_Temp_Config_Files; -- Delete all temporary config files. The caller is responsible for -- ensuring that Keep_Temporary_Files is False. @@ -385,11 +349,6 @@ procedure GNATCmd is -- includes directory information, prepend the path with Parent. This -- subprogram is only called when using project files. - function Mapping_File return Path_Name_Type; - -- Create and return the path name of a mapping file. Used for gnatstub - -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric - -- (GNAT METRIC). - procedure Output_Version; -- Output the version of this program @@ -410,23 +369,6 @@ procedure GNATCmd is For_Every_Project_Imported (Boolean, Set_Library_For); -- Add the -L and -l switches to the linker for all the library projects - -------------------------- - -- Add_To_Carg_Switches -- - -------------------------- - - procedure Add_To_Carg_Switches (Switch : String_Access) is - begin - -- If the Carg_Switches table is empty, put "-cargs" at the beginning - - if Carg_Switches.Last = 0 then - Carg_Switches.Increment_Last; - Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs"); - end if; - - Carg_Switches.Increment_Last; - Carg_Switches.Table (Carg_Switches.Last) := Switch; - end Add_To_Carg_Switches; - ----------------- -- Check_Files -- ----------------- @@ -484,8 +426,7 @@ procedure GNATCmd is -- Start of processing for Check_Files begin - -- Check if there is at least one argument that is not a switch or if - -- there is a -files= switch. + -- Check if there is at least one argument that is not a switch for Index in 1 .. Last_Switches.Last loop if Last_Switches.Table (Index) (1) /= '-' @@ -501,236 +442,67 @@ procedure GNATCmd is -- path names of all the sources of the main project. if Add_Sources then + Tempdir.Create_Temp_File (FD, Temp_File_Name); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-files=" & Get_Name_String (Temp_File_Name)); - -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file and - -- put the list of sources in it. For gnatstack create a temporary - -- file with the list of .ci files. + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop - if The_Command = List or else The_Command = Stack then - Tempdir.Create_Temp_File (FD, Temp_File_Name); - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'("-files=" & Get_Name_String (Temp_File_Name)); - end if; + -- We only need to put the library units, body or spec, but not + -- the subunits. - declare - Proj : Project_List; + if Unit.File_Names (Impl) /= null + and then not Unit.File_Names (Impl).Locally_Removed + then + -- There is a body, check if it is for this project - begin - -- Gnatstack needs to add the .ci file for the binder generated - -- files corresponding to all of the library projects and main - -- units belonging to the application. - - if The_Command = Stack then - Proj := Project_Tree.Projects; - while Proj /= null loop - if Check_Project (Proj.Project, Project) then - declare - Main : String_List_Id; + if All_Projects + or else Unit.File_Names (Impl).Project = Project + then + Subunit := False; - begin - -- Include binder generated files for main programs - - Main := Proj.Project.Mains; - while Main /= Nil_String loop - Add_To_Response_File - (Get_Name_String - (Proj.Project.Object_Directory.Name) & - B_Start & - MLib.Fil.Ext_To - (Get_Name_String - (Project_Tree.Shared.String_Elements.Table - (Main).Value), - "ci")); - - -- When looking for the .ci file for a binder - -- generated file, look for both b~xxx and b__xxx - -- as gprbuild always uses b__ as the prefix of - -- such files. - - if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) - then - Add_To_Response_File - (Get_Name_String - (Proj.Project.Object_Directory.Name) & - "b__" & - MLib.Fil.Ext_To - (Get_Name_String - (Project_Tree.Shared - .String_Elements.Table (Main).Value), - "ci")); - end if; + if Unit.File_Names (Spec) = null + or else Unit.File_Names (Spec).Locally_Removed + then + -- We have a body with no spec: we need to check if + -- this is a subunit, because gnatls will complain + -- about subunits. - Main := Project_Tree.Shared.String_Elements.Table - (Main).Next; - end loop; - - if Proj.Project.Library then - - -- Include the .ci file for the binder generated - -- files that contains the initialization and - -- finalization of the library. - - Add_To_Response_File - (Get_Name_String - (Proj.Project.Object_Directory.Name) & - B_Start & - Get_Name_String (Proj.Project.Library_Name) & - ".ci"); - - -- When looking for the .ci file for a binder - -- generated file, look for both b~xxx and b__xxx - -- as gprbuild always uses b__ as the prefix of - -- such files. - - if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) - then - Add_To_Response_File - (Get_Name_String - (Proj.Project.Object_Directory.Name) & - "b__" & - Get_Name_String (Proj.Project.Library_Name) & - ".ci"); - end if; - end if; + declare + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names (Impl).Path.Name)); + begin + Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); end; end if; - Proj := Proj.Next; - end loop; - end if; - - Unit := Units_Htable.Get_First (Project_Tree.Units_HT); - while Unit /= No_Unit_Index loop - - -- For gnatls, we only need to put the library units, body or - -- spec, but not the subunits. - - if The_Command = List then - if Unit.File_Names (Impl) /= null - and then not Unit.File_Names (Impl).Locally_Removed - then - -- There is a body, check if it is for this project - - if All_Projects - or else Unit.File_Names (Impl).Project = Project - then - Subunit := False; - - if Unit.File_Names (Spec) = null - or else Unit.File_Names (Spec).Locally_Removed - then - -- We have a body with no spec: we need to check if - -- this is a subunit, because gnatls will complain - -- about subunits. - - declare - Src_Ind : constant Source_File_Index := - Sinput.P.Load_Project_File - (Get_Name_String - (Unit.File_Names - (Impl).Path.Name)); - begin - Subunit := - Sinput.P.Source_File_Is_Subunit (Src_Ind); - end; - end if; - - if not Subunit then - Add_To_Response_File - (Get_Name_String - (Unit.File_Names (Impl).Display_File), - Check_File => False); - end if; - end if; - - elsif Unit.File_Names (Spec) /= null - and then not Unit.File_Names (Spec).Locally_Removed - then - -- We have a spec with no body. Check if it is for this - -- project. - - if All_Projects or else - Unit.File_Names (Spec).Project = Project - then - Add_To_Response_File - (Get_Name_String - (Unit.File_Names (Spec).Display_File), - Check_File => False); - end if; + if not Subunit then + Add_To_Response_File + (Get_Name_String (Unit.File_Names (Impl).Display_File), + Check_File => False); end if; + end if; - -- For gnatstack, we put the .ci files corresponding to the - -- different units, including the binder generated files. We - -- only need to do that for the library units, body or spec, - -- but not the subunits. - - elsif The_Command = Stack then - if Unit.File_Names (Impl) /= null - and then not Unit.File_Names (Impl).Locally_Removed - then - -- There is a body. Check if .ci files for this project - -- must be added. - - if Check_Project - (Unit.File_Names (Impl).Project, Project) - then - Subunit := False; - - if Unit.File_Names (Spec) = null - or else Unit.File_Names (Spec).Locally_Removed - then - -- We have a body with no spec: we need to check - -- if this is a subunit, because .ci files are not - -- generated for subunits. - - declare - Src_Ind : constant Source_File_Index := - Sinput.P.Load_Project_File - (Get_Name_String - (Unit.File_Names - (Impl).Path.Name)); - begin - Subunit := - Sinput.P.Source_File_Is_Subunit (Src_Ind); - end; - end if; - - if not Subunit then - Add_To_Response_File - (Get_Name_String - (Unit.File_Names - (Impl).Project. Object_Directory.Name) & - MLib.Fil.Ext_To - (Get_Name_String - (Unit.File_Names (Impl).Display_File), - "ci")); - end if; - end if; - - elsif Unit.File_Names (Spec) /= null - and then not Unit.File_Names (Spec).Locally_Removed - then - -- Spec with no body, check if it is for this project + elsif Unit.File_Names (Spec) /= null + and then not Unit.File_Names (Spec).Locally_Removed + then + -- We have a spec with no body. Check if it is for this project - if Check_Project - (Unit.File_Names (Spec).Project, Project) - then - Add_To_Response_File - (Get_Name_String - (Unit.File_Names - (Spec).Project. Object_Directory.Name) & - Dir_Separator & - MLib.Fil.Ext_To - (Get_Name_String (Unit.File_Names (Spec).File), - "ci")); - end if; - end if; + if All_Projects + or else Unit.File_Names (Spec).Project = Project + then + Add_To_Response_File + (Get_Name_String (Unit.File_Names (Spec).Display_File), + Check_File => False); end if; + end if; - Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); - end loop; - end; + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; if FD /= Invalid_FD then Close (FD, Success); @@ -742,25 +514,6 @@ procedure GNATCmd is end if; end Check_Files; - ------------------- - -- Check_Project -- - ------------------- - - function Check_Project - (Project : Project_Id; - Root_Project : Project_Id) return Boolean - is - begin - if Project = No_Project then - return False; - - elsif All_Projects or else Project = Root_Project then - return True; - end if; - - return False; - end Check_Project; - ------------------------------- -- Check_Relative_Executable -- ------------------------------- @@ -785,24 +538,13 @@ procedure GNATCmd is Name_Buffer (Name_Len) := Directory_Separator; end if; - Name_Buffer (Name_Len + 1 .. - Name_Len + Exec_File_Name'Length) := + Name_Buffer (Name_Len + 1 .. Name_Len + Exec_File_Name'Length) := Exec_File_Name; Name_Len := Name_Len + Exec_File_Name'Length; Name := new String'(Name_Buffer (1 .. Name_Len)); end if; end Check_Relative_Executable; - -------------------------------- - -- Configuration_Pragmas_File -- - -------------------------------- - - function Configuration_Pragmas_File return Path_Name_Type is - begin - Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); - return Project.Config_File_Name; - end Configuration_Pragmas_File; - ------------------------------ -- Delete_Temp_Config_Files -- ------------------------------ @@ -853,21 +595,6 @@ procedure GNATCmd is Including_RTS => True); end Ensure_Absolute_Path; - ------------------ - -- Mapping_File -- - ------------------ - - function Mapping_File return Path_Name_Type is - Result : Path_Name_Type; - begin - Prj.Env.Create_Mapping_File - (Project => Project, - Language => Name_Ada, - In_Tree => Project_Tree, - Name => Result); - return Result; - end Mapping_File; - -------------------- -- Output_Version -- -------------------- @@ -881,9 +608,8 @@ procedure GNATCmd is end if; Put_Line (Gnatvsn.Gnat_Version_String); - Put_Line ("Copyright 1996-" & - Gnatvsn.Current_Year & - ", Free Software Foundation, Inc."); + Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year + & ", Free Software Foundation, Inc."); end Output_Version; ----------- @@ -899,45 +625,34 @@ procedure GNATCmd is for C in Command_List'Range loop - -- No usage for Sync - - if C /= Sync then - if Targparm.AAMP_On_Target then - Put ("gnaampcmd "); - else - Put ("gnat "); - end if; - - Put (To_Lower (Command_List (C).Cname.all)); - Set_Col (25); + if Targparm.AAMP_On_Target then + Put ("gnaampcmd "); + else + Put ("gnat "); + end if; - -- Never call gnatstack with a prefix + Put (To_Lower (Command_List (C).Cname.all)); + Set_Col (25); + Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); - if C = Stack then - Put (Command_List (C).Unixcmd.all); - else - Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); + declare + Sws : Argument_List_Access renames Command_List (C).Unixsws; + begin + if Sws /= null then + for J in Sws'Range loop + Put (' '); + Put (Sws (J).all); + end loop; end if; + end; - declare - Sws : Argument_List_Access renames Command_List (C).Unixsws; - begin - if Sws /= null then - for J in Sws'Range loop - Put (' '); - Put (Sws (J).all); - end loop; - end if; - end; - - New_Line; - end if; + New_Line; end loop; New_Line; - Put_Line ("All commands except chop, krunch and preprocess " & - "accept project file switches -vPx, -Pprj, -Xnam=val," & - "--subdirs= and -eL"); + Put_Line ("Commands bind, find, link, list and xref " + & "accept project file switches -vPx, -Pprj, -Xnam=val," + & "--subdirs= and -eL"); New_Line; end Usage; @@ -956,8 +671,8 @@ procedure GNATCmd is Skip_Executable : Boolean := False; begin - -- Add the default search directories, to be able to find - -- libgnat in call to MLib.Utl.Lib_Directory. + -- Add the default search directories, to be able to find libgnat in + -- call to MLib.Utl.Lib_Directory. Add_Default_Search_Dirs; @@ -1013,9 +728,8 @@ procedure GNATCmd is else -- First, compute the exact length for the switch - for Index in - Library_Paths.First .. Library_Paths.Last - loop + for Index in Library_Paths.First .. Library_Paths.Last loop + -- Add the length of the library dir plus one for the -- directory separator. @@ -1038,27 +752,23 @@ procedure GNATCmd is loop Option (Current + 1 .. - Current + - Library_Paths.Table (Index)'Length) := + Current + Library_Paths.Table (Index)'Length) := Library_Paths.Table (Index).all; Current := - Current + - Library_Paths.Table (Index)'Length + 1; + Current + Library_Paths.Table (Index)'Length + 1; Option (Current) := Path_Separator; end loop; -- Finally put the standard GNAT library dir Option - (Current + 1 .. - Current + MLib.Utl.Lib_Directory'Length) := + (Current + 1 .. Current + MLib.Utl.Lib_Directory'Length) := MLib.Utl.Lib_Directory; -- And add the switch to the last switches Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - Option; + Last_Switches.Table (Last_Switches.Last) := Option; end if; end; end if; @@ -1087,8 +797,7 @@ procedure GNATCmd is else declare - Switch : constant String := - Last_Switches.Table (J).all; + Switch : constant String := Last_Switches.Table (J).all; ALI_File : constant String (1 .. Switch'Length + 4) := Switch & ".ali"; @@ -1138,10 +847,8 @@ procedure GNATCmd is Dir : constant String := Get_Name_String (Prj.Object_Directory.Name); begin - if Is_Regular_File - (Dir & - ALI_File (1 .. Last)) - then + if Is_Regular_File (Dir & ALI_File (1 .. Last)) then + -- We have found the correct project, so we -- replace the file with the absolute path. @@ -1170,8 +877,7 @@ procedure GNATCmd is for J in reverse 1 .. Last_Switches.Last - 1 loop if Last_Switches.Table (J).all = "-o" then - Check_Relative_Executable - (Name => Last_Switches.Table (J + 1)); + Check_Relative_Executable (Name => Last_Switches.Table (J + 1)); Look_For_Executable := False; exit; end if; @@ -1235,8 +941,7 @@ procedure GNATCmd is is pragma Unreferenced (Tree); - Path_Option : constant String_Access := - MLib.Linker_Library_Path_Option; + Path_Option : constant String_Access := MLib.Linker_Library_Path_Option; begin -- Case of library project @@ -1269,8 +974,7 @@ procedure GNATCmd is end if; end Set_Library_For; - procedure Check_Version_And_Help is - new Check_Version_And_Help_G (Usage); + procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); -- Start of processing for GNATCmd @@ -1333,12 +1037,9 @@ begin if Command (Index) = Directory_Separator then declare Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - - PATH : constant String := - Absolute_Dir & Path_Separator & Getenv ("PATH").all; - + Normalize_Pathname (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir & Path_Separator & Getenv ("PATH").all; begin Setenv ("PATH", PATH); end; @@ -1391,8 +1092,7 @@ begin Alternate : Alternate_Command; begin - Alternate := Alternate_Command'Value - (Argument (Command_Arg)); + Alternate := Alternate_Command'Value (Argument (Command_Arg)); The_Command := Corresponding_To (Alternate); exception @@ -1422,9 +1122,8 @@ begin -- Open the file and fail if the file cannot be found begin - Open - (Arg_File, In_File, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + Open (Arg_File, In_File, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); exception when others => @@ -1456,8 +1155,7 @@ begin -- the Last_Switches table. Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(The_Arg); + Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg); end if; end; end loop; @@ -1506,8 +1204,8 @@ begin end loop; end if; - -- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB, - -- SYNC and XREF, look for project file related switches. + -- For BIND, FIND, LINK, LIST and XREF, look for project file related + -- switches. case The_Command is when Bind => @@ -1522,12 +1220,6 @@ begin when List => Tool_Package_Name := Name_Gnatls; Packages_To_Check := Packages_To_Check_By_Gnatls; - when Stack => - Tool_Package_Name := Name_Stack; - Packages_To_Check := Packages_To_Check_By_Stack; - when Sync => - Tool_Package_Name := Name_Synchronize; - Packages_To_Check := Packages_To_Check_By_Sync; when Xref => Tool_Package_Name := Name_Cross_Reference; Packages_To_Check := Packages_To_Check_By_Xref; @@ -1566,8 +1258,7 @@ begin if Argv (Argv'First) = '-' then if Argv'Length = 1 then - Fail - ("switch character cannot be followed by a blank"); + Fail ("switch character cannot be followed by a blank"); end if; -- The two style project files (-p and -P) cannot be used @@ -1589,13 +1280,12 @@ begin Argv (Argv'First .. Argv'First + Makeutl.Subdirs_Option'Length - 1) = - Makeutl.Subdirs_Option + Makeutl.Subdirs_Option then Subdirs := new String' - (Argv - (Argv'First + Makeutl.Subdirs_Option'Length .. - Argv'Last)); + (Argv (Argv'First + Makeutl.Subdirs_Option'Length .. + Argv'Last)); Remove_Switch (Arg_Num); @@ -1630,7 +1320,7 @@ begin and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" then if Argv'Length = 4 - and then Argv (Argv'Last) in '0' .. '2' + and then Argv (Argv'Last) in '0' .. '2' then case Argv (Argv'Last) is when '0' => @@ -1662,8 +1352,7 @@ begin Fail (Argv.all & ": second project file forbidden (first is """ - & Project_File.all - & """)"); + & Project_File.all & """)"); -- The two style project files (-p and -P) cannot be -- used together. @@ -1712,16 +1401,14 @@ begin if not Check (Root_Environment.External, Argv (Argv'First + 2 .. Argv'Last)) then - Fail (Argv.all - & " is not a valid external assignment."); + Fail + (Argv.all & " is not a valid external assignment."); end if; Remove_Switch (Arg_Num); elsif - (The_Command = Sync or else - The_Command = Stack or else - The_Command = List) + The_Command = List and then Argv'Length = 2 and then Argv (2) = 'U' then @@ -1798,10 +1485,10 @@ begin if Pkg /= No_Package then Element := Project_Tree.Shared.Packages.Table (Pkg); - -- Packages Gnatls and Gnatstack have a single attribute - -- Switches, that is not an associative array. + -- Package Gnatls has a single attribute Switches, that is not + -- an associative array. - if The_Command = List or else The_Command = Stack then + if The_Command = List then The_Switches := Prj.Util.Value_Of (Variable_Name => Snames.Name_Switches, @@ -1823,7 +1510,6 @@ begin if Last_Switches.Table (J) (1) /= '-' then if Main = null then Main := Last_Switches.Table (J); - else Main := null; exit; @@ -1883,7 +1569,6 @@ begin declare Switch : constant String := Get_Name_String (The_Switches.Value); - begin if Switch'Length > 0 then First_Switches.Increment_Last; @@ -1900,8 +1585,7 @@ begin declare Switch : constant String := - Get_Name_String (The_String.Value); - + Get_Name_String (The_String.Value); begin if Switch'Length > 0 then First_Switches.Increment_Last; @@ -1933,189 +1617,6 @@ begin -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- a configuration pragmas file, if necessary. - if The_Command = Sync then - - -- If there are switches in package Compiler, put them in the - -- Carg_Switches table. - - declare - Pkg : constant Prj.Package_Id := - Prj.Util.Value_Of - (Name => Name_Compiler, - In_Packages => Project.Decl.Packages, - Shared => Project_Tree.Shared); - - Element : Package_Element; - - Switches_Array : Array_Element_Id; - - The_Switches : Prj.Variable_Value; - Current : Prj.String_List_Id; - The_String : String_Element; - - Main : String_Access := null; - Main_Id : Name_Id; - - begin - if Pkg /= No_Package then - - -- First, check if there is a single main specified - - for J in 1 .. Last_Switches.Last loop - if Last_Switches.Table (J) (1) /= '-' then - if Main = null then - Main := Last_Switches.Table (J); - - else - Main := null; - exit; - end if; - end if; - end loop; - - Element := Project_Tree.Shared.Packages.Table (Pkg); - - -- If there is a single main and there is compilation - -- switches specified in the project file, use them. - - if Main /= null and then not All_Projects then - Name_Len := Main'Length; - Name_Buffer (1 .. Name_Len) := Main.all; - Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); - Main_Id := Name_Find; - - Switches_Array := - Prj.Util.Value_Of - (Name => Name_Switches, - In_Arrays => Element.Decl.Arrays, - Shared => Project_Tree.Shared); - The_Switches := Prj.Util.Value_Of - (Index => Main_Id, - Src_Index => 0, - In_Array => Switches_Array, - Shared => Project_Tree.Shared); - end if; - - -- Otherwise, get the Default_Switches ("Ada") - - if The_Switches.Kind = Undefined then - Switches_Array := - Prj.Util.Value_Of - (Name => Name_Default_Switches, - In_Arrays => Element.Decl.Arrays, - Shared => Project_Tree.Shared); - The_Switches := Prj.Util.Value_Of - (Index => Name_Ada, - Src_Index => 0, - In_Array => Switches_Array, - Shared => Project_Tree.Shared); - end if; - - -- If there are switches specified, put them in the - -- Carg_Switches table. - - case The_Switches.Kind is - when Prj.Undefined => - null; - - when Prj.Single => - declare - Switch : constant String := - Get_Name_String (The_Switches.Value); - begin - if Switch'Length > 0 then - Add_To_Carg_Switches (new String'(Switch)); - end if; - end; - - when Prj.List => - Current := The_Switches.Values; - while Current /= Prj.Nil_String loop - The_String := Project_Tree.Shared.String_Elements - .Table (Current); - - declare - Switch : constant String := - Get_Name_String (The_String.Value); - begin - if Switch'Length > 0 then - Add_To_Carg_Switches (new String'(Switch)); - end if; - end; - - Current := The_String.Next; - end loop; - end case; - end if; - end; - - -- If -cargs is one of the switches, move the following switches - -- to the Carg_Switches table. - - for J in 1 .. First_Switches.Last loop - if First_Switches.Table (J).all = "-cargs" then - declare - K : Positive; - Last : Natural; - - begin - -- Move the switches that are before -rules when the - -- command is CHECK. - - K := J + 1; - while K <= First_Switches.Last loop - Add_To_Carg_Switches (First_Switches.Table (K)); - K := K + 1; - end loop; - - if K > First_Switches.Last then - First_Switches.Set_Last (J - 1); - - else - Last := J - 1; - while K <= First_Switches.Last loop - Last := Last + 1; - First_Switches.Table (Last) := - First_Switches.Table (K); - K := K + 1; - end loop; - - First_Switches.Set_Last (Last); - end if; - end; - - exit; - end if; - end loop; - - for J in 1 .. Last_Switches.Last loop - if Last_Switches.Table (J).all = "-cargs" then - for K in J + 1 .. Last_Switches.Last loop - Add_To_Carg_Switches (Last_Switches.Table (K)); - end loop; - - Last_Switches.Set_Last (J - 1); - exit; - end if; - end loop; - - declare - CP_File : constant Path_Name_Type := Configuration_Pragmas_File; - M_File : constant Path_Name_Type := Mapping_File; - - begin - if CP_File /= No_Path then - Add_To_Carg_Switches - (new String'("-gnatec=" & Get_Name_String (CP_File))); - end if; - - if M_File /= No_Path then - Add_To_Carg_Switches - (new String'("-gnatem=" & Get_Name_String (M_File))); - end if; - end; - end if; - if The_Command = Link then Process_Link; end if; @@ -2146,17 +1647,10 @@ begin end; end if; - -- For gnat sync with -U + a main, get the list of sources from the - -- closure and add them to the arguments. - - -- For gnat sync, gnat list, and gnat stack, if no file has been put - -- on the command line, call tool with all the sources of the main - -- project. + -- For gnat list, if no file has been put on the command line, call + -- tool with all the sources of the main project. - if The_Command = Sync or else - The_Command = List or else - The_Command = Stack - then + if The_Command = List then Check_Files; end if; end if; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 7bc5b23..201d6b8 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -326,12 +326,6 @@ package body Prj.Attr is "Ladefault_switches#" & "LbOswitches#" & - -- package Synchronize - - "Psynchronize#" & - "Ladefault_switches#" & - "LbOswitches#" & - -- package Eliminate "Peliminate#" & diff --git a/gcc/ada/s-linux-android.ads b/gcc/ada/s-linux-android.ads index 85c4210..d02b96e 100644 --- a/gcc/ada/s-linux-android.ads +++ b/gcc/ada/s-linux-android.ads @@ -47,6 +47,7 @@ package System.Linux is subtype long is Interfaces.C.long; subtype suseconds_t is Interfaces.C.long; subtype time_t is Interfaces.C.long; + subtype clockid_t is Interfaces.C.int; type timespec is record tv_sec : time_t; diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index 6fce65f..5df0353 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2014, 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- -- @@ -206,6 +206,11 @@ package System.OS_Interface is tp : access timespec) return int; pragma Import (C, clock_gettime, "clock_gettime"); + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); diff --git a/gcc/ada/s-osinte-android.ads b/gcc/ada/s-osinte-android.ads index 310c598..abf5dae 100644 --- a/gcc/ada/s-osinte-android.ads +++ b/gcc/ada/s-osinte-android.ads @@ -211,6 +211,11 @@ package System.OS_Interface is (clock_id : clockid_t; tp : access timespec) return int; + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); diff --git a/gcc/ada/s-osinte-darwin.adb b/gcc/ada/s-osinte-darwin.adb index e5add8a..315f796 100644 --- a/gcc/ada/s-osinte-darwin.adb +++ b/gcc/ada/s-osinte-darwin.adb @@ -129,6 +129,36 @@ package body System.OS_Interface is return Result; end clock_gettime; + ------------------ + -- clock_getres -- + ------------------ + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int + is + pragma Unreferenced (clock_id); + + -- Darwin Threads don't have clock_getres. + + Nano : constant := 10**9; + nsec : int := 0; + Result : int := -1; + + function clock_get_res return int; + pragma Import (C, clock_get_res, "__gnat_clock_get_res"); + + begin + nsec := clock_get_res; + res.all := To_Timespec (Duration (0.0) + Duration (nsec) / Nano); + + if nsec > 0 then + Result := 0; + end if; + + return Result; + end clock_getres; + ----------------- -- sched_yield -- ----------------- diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index ff04803..9eaa212 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2014, 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- -- @@ -189,6 +189,10 @@ package System.OS_Interface is (clock_id : clockid_t; tp : access timespec) return int; + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index b581dae..625d2dc 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2014, 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- -- @@ -202,6 +202,11 @@ package System.OS_Interface is type clockid_t is new int; + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + function clock_gettime (clock_id : clockid_t; tp : access timespec) diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads index fed4019..a84d635 100644 --- a/gcc/ada/s-osinte-mingw.ads +++ b/gcc/ada/s-osinte-mingw.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2014, 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- -- @@ -53,6 +53,8 @@ package System.OS_Interface is subtype int is Interfaces.C.int; subtype long is Interfaces.C.long; + subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER; + ------------------- -- General Types -- ------------------- @@ -104,6 +106,18 @@ package System.OS_Interface is procedure kill (sig : Signal); pragma Import (C, kill, "raise"); + ------------ + -- Clock -- + ------------ + + procedure QueryPerformanceFrequency + (lpPerformanceFreq : access LARGE_INTEGER); + pragma Import + (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); + + -- According to the spec, on XP and later than function cannot fail, + -- so we ignore the return value and import it as a procedure. + ------------- -- Threads -- ------------- diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index 0859b8d..4e27fd1 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -189,6 +189,11 @@ package System.OS_Interface is type clockid_t is new int; + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + function clock_gettime (clock_id : clockid_t; tp : access timespec) return int; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index bf5e992..a43133a 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -662,6 +662,7 @@ package body System.Task_Primitives.Operations is function RT_Resolution return Duration is TS : aliased timespec; Result : int; + begin Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); pragma Assert (Result = 0); diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 126ef64..cecb7e5 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -1076,8 +1076,10 @@ package body System.Task_Primitives.Operations is ------------------- function RT_Resolution return Duration is + Ticks_Per_Second : aliased LARGE_INTEGER; begin - return 0.000_001; -- 1 micro-second + QueryPerformanceFrequency (Ticks_Per_Second'Access); + return Duration (1.0 / Ticks_Per_Second); end RT_Resolution; ---------------- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 8aff965..cdbc064 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -743,8 +743,13 @@ package body System.Task_Primitives.Operations is ------------------- function RT_Resolution return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; begin - return 10#1.0#E-6; + Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + + return To_Duration (TS); end RT_Resolution; ------------ diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 1d87979..a508c42 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -785,8 +785,13 @@ package body System.Task_Primitives.Operations is ------------------- function RT_Resolution return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; begin - return 10#1.0#E-6; + Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + + return To_Duration (TS); end RT_Resolution; ----------- diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 5353326..947e5ac 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -989,7 +989,7 @@ package body System.Tasking.Stages is return; end if; - Initialization.Defer_Abort (Self_ID); + Initialization.Defer_Abort_Nestable (Self_ID); -- Loop through the From chain, changing their Master_of_Task fields, -- and to find the end of the chain. @@ -1009,7 +1009,7 @@ package body System.Tasking.Stages is From.all.T_ID := null; - Initialization.Undefer_Abort (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); end Move_Activation_Chain; ------------------ @@ -2011,9 +2011,9 @@ package body System.Tasking.Stages is (Self_ID.Deferral_Level > 0 or else not System.Restrictions.Abort_Allowed); pragma Assert (Self_ID = Self); - pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 - or else - Self_ID.Master_Within = Self_ID.Master_of_Task + 2); + pragma Assert + (Self_ID.Master_Within in + Self_ID.Master_of_Task + 1 .. Self_ID.Master_of_Task + 3); pragma Assert (Self_ID.Common.Wait_Count = 0); pragma Assert (Self_ID.Open_Accepts = null); pragma Assert (Self_ID.ATC_Nesting_Level = 1); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5e987bc..1335dcf 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2094,6 +2094,14 @@ package body Sem_Ch6 is elsif Is_Tagged_Type (Typ) then null; + -- Use is legal in a thunk generated for an operation + -- inherited from a progenitor. + + elsif Is_Thunk (Designator) + and then Present (Non_Limited_View (Typ)) + then + null; + elsif Nkind (Parent (N)) = N_Subprogram_Body or else Nkind_In (Parent (Parent (N)), N_Accept_Statement, N_Entry_Body) diff --git a/gcc/ada/thread.c b/gcc/ada/thread.c index 31309e0..bd3cfa6 100644 --- a/gcc/ada/thread.c +++ b/gcc/ada/thread.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2011-2013, Free Software Foundation, Inc. * + * Copyright (C) 2011-2014, 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- * @@ -54,3 +54,35 @@ __gnat_pthread_condattr_setup (void *attr) { } #endif + +#if defined (__APPLE__) +#include +#include +#endif + +/* Return the clock ticks per nanosecond for Posix systems lacking the + Posix extension function clock_getres, or else 0 nsecs on error. */ + +int +__gnat_clock_get_res (void) +{ +#if defined (__APPLE__) + clock_serv_t clock_port; + mach_msg_type_number_t count; + int nsecs; + int result; + + count = 1; + result = host_get_clock_service + (mach_host_self (), SYSTEM_CLOCK, &clock_port); + + if (result == KERN_SUCCESS) + result = clock_get_attributes (clock_port, CLOCK_GET_TIME_RES, + (clock_attr_t) &nsecs, &count); + + if (result == KERN_SUCCESS) + return nsecs; +#endif + + return 0; +} -- 2.7.4