Skip to content

R
riscv-gcc-1
Commit ed09416f by Arnaud Charlet
Options

[multiple changes] 

2015-01-07  Robert Dewar  <dewar@adacore.com>

	* s-taprop-linux.adb, clean.adb: Minor reformatting.

2015-01-07  Arnaud Charlet  <charlet@adacore.com>

	* s-tassta.adb: Relax some overzealous assertions.

2015-01-07  Ed Schonberg  <schonberg@adacore.com>

	* 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  <rupp@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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  <celier@adacore.com>

	* 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.

From-SVN: r219291
parent 6a989c79
Showing with 264 additions and 586 deletions
gcc/ada/ChangeLog
2015-01-07 Robert Dewar <dewar@adacore.com>
* s-taprop-linux.adb, clean.adb: Minor reformatting.
2015-01-07 Arnaud Charlet <charlet@adacore.com>
* s-tassta.adb: Relax some overzealous assertions.
2015-01-07 Ed Schonberg <schonberg@adacore.com>
* 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 <rupp@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <celier@adacore.com>
* 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 <celier@adacore.com> 2015-01-07 Vincent Celier <celier@adacore.com>
* clean.adb: Minor error message change. * clean.adb: Minor error message change.
......
gcc/ada/clean.adb
...@@ -1387,8 +1387,8 @@ package body Clean is ...@@ -1387,8 +1387,8 @@ package body Clean is
if Project_File_Name /= null then if Project_File_Name /= null then
Put_Line Put_Line
("warning: gnatclean -P is obsolete and will not be available " & ("warning: gnatclean -P is obsolete and will not be available "
"in the next release; use gprclean instead."); & "in the next release; use gprclean instead.");
end if; end if;
-- A project file was specified by a -P switch -- A project file was specified by a -P switch
...@@ -1655,7 +1655,8 @@ package body Clean is ...@@ -1655,7 +1655,8 @@ package body Clean is
case Arg (2) is case Arg (2) is
when '-' => when '-' =>
if Arg'Length > Subdirs_Option'Length and then if Arg'Length > Subdirs_Option'Length
and then
Arg (1 .. Subdirs_Option'Length) = Subdirs_Option Arg (1 .. Subdirs_Option'Length) = Subdirs_Option
then then
Subdirs := Subdirs :=
...@@ -1790,7 +1791,8 @@ package body Clean is ...@@ -1790,7 +1791,8 @@ package body Clean is
declare declare
Prj : constant String := Arg (3 .. Arg'Last); Prj : constant String := Arg (3 .. Arg'Last);
begin begin
if Prj'Length > 1 and then Prj (Prj'First) = '=' if Prj'Length > 1
and then Prj (Prj'First) = '='
then then
Project_File_Name := Project_File_Name :=
new String' new String'
......
gcc/ada/exp_ch6.adb
...@@ -5914,6 +5914,14 @@ package body Exp_Ch6 is ...@@ -5914,6 +5914,14 @@ package body Exp_Ch6 is
elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then
null; 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 elsif not Requires_Transient_Scope (R_Type) then
-- Mutable records with no variable length components are not -- Mutable records with no variable length components are not
......
gcc/ada/exp_util.adb
...@@ -6074,6 +6074,16 @@ package body Exp_Util is ...@@ -6074,6 +6074,16 @@ package body Exp_Util is
or else Is_Constrained (Root_Typ) or else Is_Constrained (Root_Typ)
then then
Constr_Root := Root_Typ; 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 else
Constr_Root := Make_Temporary (Loc, 'R'); Constr_Root := Make_Temporary (Loc, 'R');
......
gcc/ada/gnatcmd.adb
...@@ -30,7 +30,6 @@ with Gnatvsn; ...@@ -30,7 +30,6 @@ with Gnatvsn;
with Makeutl; use Makeutl; with Makeutl; use Makeutl;
with MLib.Tgt; use MLib.Tgt; with MLib.Tgt; use MLib.Tgt;
with MLib.Utl; with MLib.Utl;
with MLib.Fil;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Osint; use Osint; with Osint; use Osint;
...@@ -70,7 +69,6 @@ procedure GNATCmd is ...@@ -70,7 +69,6 @@ procedure GNATCmd is
Clean, Clean,
Compile, Compile,
Check, Check,
Sync,
Elim, Elim,
Find, Find,
Krunch, Krunch,
...@@ -107,9 +105,6 @@ procedure GNATCmd is ...@@ -107,9 +105,6 @@ procedure GNATCmd is
Current_Verbosity : Prj.Verbosity := Prj.Default; Current_Verbosity : Prj.Verbosity := Prj.Default;
Tool_Package_Name : Name_Id := No_Name; Tool_Package_Name : Name_Id := No_Name;
B_Start : constant String := "b~";
-- Prefix of binder generated file
Project_Tree : constant Project_Tree_Ref := Project_Tree : constant Project_Tree_Ref :=
new Project_Tree_Data (Is_Root_Tree => True); new Project_Tree_Data (Is_Root_Tree => True);
-- The project tree -- The project tree
...@@ -174,20 +169,14 @@ procedure GNATCmd is ...@@ -174,20 +169,14 @@ procedure GNATCmd is
Naming_String : constant SA := new String'("naming"); Naming_String : constant SA := new String'("naming");
Binder_String : constant SA := new String'("binder"); 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"); Finder_String : constant SA := new String'("finder");
Linker_String : constant SA := new String'("linker"); Linker_String : constant SA := new String'("linker");
Gnatls_String : constant SA := new String'("gnatls"); Gnatls_String : constant SA := new String'("gnatls");
Stack_String : constant SA := new String'("stack");
Xref_String : constant SA := new String'("cross_reference"); Xref_String : constant SA := new String'("cross_reference");
Packages_To_Check_By_Binder : constant String_List_Access := Packages_To_Check_By_Binder : constant String_List_Access :=
new String_List'((Naming_String, Binder_String)); 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 := Packages_To_Check_By_Finder : constant String_List_Access :=
new String_List'((Naming_String, Finder_String)); new String_List'((Naming_String, Finder_String));
...@@ -197,9 +186,6 @@ procedure GNATCmd is ...@@ -197,9 +186,6 @@ procedure GNATCmd is
Packages_To_Check_By_Gnatls : constant String_List_Access := Packages_To_Check_By_Gnatls : constant String_List_Access :=
new String_List'((Naming_String, Gnatls_String)); 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 := Packages_To_Check_By_Xref : constant String_List_Access :=
new String_List'((Naming_String, Xref_String)); new String_List'((Naming_String, Xref_String));
...@@ -222,9 +208,9 @@ procedure GNATCmd is ...@@ -222,9 +208,9 @@ procedure GNATCmd is
-- The path of the working directory -- The path of the working directory
All_Projects : Boolean := False; All_Projects : Boolean := False;
-- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to -- Flag used for GNAT CHECK, GNAT PRETTY and GNAT METRIC to indicate that
-- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) -- the underlying tool (gnatcheck, gnatpp or gnatmetric) should be invoked
-- should be invoked for all sources of all projects. -- for all sources of all projects.
type Command_Entry is record type Command_Entry is record
Cname : String_Access; Cname : String_Access;
...@@ -265,11 +251,6 @@ procedure GNATCmd is ...@@ -265,11 +251,6 @@ procedure GNATCmd is
Unixcmd => new String'("gnatcheck"), Unixcmd => new String'("gnatcheck"),
Unixsws => null), Unixsws => null),
Sync =>
(Cname => new String'("SYNC"),
Unixcmd => new String'("gnatsync"),
Unixsws => null),
Elim => Elim =>
(Cname => new String'("ELIM"), (Cname => new String'("ELIM"),
Unixcmd => new String'("gnatelim"), Unixcmd => new String'("gnatelim"),
...@@ -345,22 +326,11 @@ procedure GNATCmd is ...@@ -345,22 +326,11 @@ procedure GNATCmd is
-- Local Subprograms -- -- 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; procedure Check_Files;
-- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a -- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project file
-- project file is specified, without any file arguments and without a -- is specified, without any file arguments and without a switch -files=.
-- switch -files=. If it is the case, invoke the GNAT tool with the proper -- If it is the case, invoke the GNAT tool with the proper list of files,
-- list of files, derived from the sources of the project. -- 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.
procedure Check_Relative_Executable (Name : in out String_Access); procedure Check_Relative_Executable (Name : in out String_Access);
-- Check if an executable is specified as a relative path. If it is, and -- Check if an executable is specified as a relative path. If it is, and
...@@ -368,12 +338,6 @@ procedure GNATCmd is ...@@ -368,12 +338,6 @@ procedure GNATCmd is
-- exec directory. This procedure is only used for GNAT LINK when a project -- exec directory. This procedure is only used for GNAT LINK when a project
-- file is specified. -- 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; procedure Delete_Temp_Config_Files;
-- Delete all temporary config files. The caller is responsible for -- Delete all temporary config files. The caller is responsible for
-- ensuring that Keep_Temporary_Files is False. -- ensuring that Keep_Temporary_Files is False.
...@@ -385,11 +349,6 @@ procedure GNATCmd is ...@@ -385,11 +349,6 @@ procedure GNATCmd is
-- includes directory information, prepend the path with Parent. This -- includes directory information, prepend the path with Parent. This
-- subprogram is only called when using project files. -- 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; procedure Output_Version;
-- Output the version of this program -- Output the version of this program
...@@ -410,23 +369,6 @@ procedure GNATCmd is ...@@ -410,23 +369,6 @@ procedure GNATCmd is
For_Every_Project_Imported (Boolean, Set_Library_For); For_Every_Project_Imported (Boolean, Set_Library_For);
-- Add the -L and -l switches to the linker for all the library projects -- 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 -- -- Check_Files --
----------------- -----------------
...@@ -484,8 +426,7 @@ procedure GNATCmd is ...@@ -484,8 +426,7 @@ procedure GNATCmd is
-- Start of processing for Check_Files -- Start of processing for Check_Files
begin begin
-- Check if there is at least one argument that is not a switch or if -- Check if there is at least one argument that is not a switch
-- there is a -files= switch.
for Index in 1 .. Last_Switches.Last loop for Index in 1 .. Last_Switches.Last loop
if Last_Switches.Table (Index) (1) /= '-' if Last_Switches.Table (Index) (1) /= '-'
...@@ -501,112 +442,17 @@ procedure GNATCmd is ...@@ -501,112 +442,17 @@ procedure GNATCmd is
-- path names of all the sources of the main project. -- path names of all the sources of the main project.
if Add_Sources then if Add_Sources then
-- 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.
if The_Command = List or else The_Command = Stack then
Tempdir.Create_Temp_File (FD, Temp_File_Name); Tempdir.Create_Temp_File (FD, Temp_File_Name);
Last_Switches.Increment_Last; Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) := Last_Switches.Table (Last_Switches.Last) :=
new String'("-files=" & Get_Name_String (Temp_File_Name)); new String'("-files=" & Get_Name_String (Temp_File_Name));
end if;
declare
Proj : Project_List;
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;
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;
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;
end;
end if;
Proj := Proj.Next;
end loop;
end if;
Unit := Units_Htable.Get_First (Project_Tree.Units_HT); Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
while Unit /= No_Unit_Index loop while Unit /= No_Unit_Index loop
-- For gnatls, we only need to put the library units, body or -- We only need to put the library units, body or spec, but not
-- spec, but not the subunits. -- the subunits.
if The_Command = List then
if Unit.File_Names (Impl) /= null if Unit.File_Names (Impl) /= null
and then not Unit.File_Names (Impl).Locally_Removed and then not Unit.File_Names (Impl).Locally_Removed
then then
...@@ -628,18 +474,15 @@ procedure GNATCmd is ...@@ -628,18 +474,15 @@ procedure GNATCmd is
Src_Ind : constant Source_File_Index := Src_Ind : constant Source_File_Index :=
Sinput.P.Load_Project_File Sinput.P.Load_Project_File
(Get_Name_String (Get_Name_String
(Unit.File_Names (Unit.File_Names (Impl).Path.Name));
(Impl).Path.Name));
begin begin
Subunit := Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind);
Sinput.P.Source_File_Is_Subunit (Src_Ind);
end; end;
end if; end if;
if not Subunit then if not Subunit then
Add_To_Response_File Add_To_Response_File
(Get_Name_String (Get_Name_String (Unit.File_Names (Impl).Display_File),
(Unit.File_Names (Impl).Display_File),
Check_File => False); Check_File => False);
end if; end if;
end if; end if;
...@@ -647,90 +490,19 @@ procedure GNATCmd is ...@@ -647,90 +490,19 @@ procedure GNATCmd is
elsif Unit.File_Names (Spec) /= null elsif Unit.File_Names (Spec) /= null
and then not Unit.File_Names (Spec).Locally_Removed and then not Unit.File_Names (Spec).Locally_Removed
then then
-- We have a spec with no body. Check if it is for this -- We have a spec with no body. Check if it is for this project
-- project.
if All_Projects or else if All_Projects
Unit.File_Names (Spec).Project = Project or else Unit.File_Names (Spec).Project = Project
then then
Add_To_Response_File Add_To_Response_File
(Get_Name_String (Get_Name_String (Unit.File_Names (Spec).Display_File),
(Unit.File_Names (Spec).Display_File),
Check_File => False); Check_File => False);
end if; end if;
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
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;
end if;
Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
end loop; end loop;
end;
if FD /= Invalid_FD then if FD /= Invalid_FD then
Close (FD, Success); Close (FD, Success);
...@@ -742,25 +514,6 @@ procedure GNATCmd is ...@@ -742,25 +514,6 @@ procedure GNATCmd is
end if; end if;
end Check_Files; 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 -- -- Check_Relative_Executable --
------------------------------- -------------------------------
...@@ -785,24 +538,13 @@ procedure GNATCmd is ...@@ -785,24 +538,13 @@ procedure GNATCmd is
Name_Buffer (Name_Len) := Directory_Separator; Name_Buffer (Name_Len) := Directory_Separator;
end if; end if;
Name_Buffer (Name_Len + 1 .. Name_Buffer (Name_Len + 1 .. Name_Len + Exec_File_Name'Length) :=
Name_Len + Exec_File_Name'Length) :=
Exec_File_Name; Exec_File_Name;
Name_Len := Name_Len + Exec_File_Name'Length; Name_Len := Name_Len + Exec_File_Name'Length;
Name := new String'(Name_Buffer (1 .. Name_Len)); Name := new String'(Name_Buffer (1 .. Name_Len));
end if; end if;
end Check_Relative_Executable; 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 -- -- Delete_Temp_Config_Files --
------------------------------ ------------------------------
...@@ -853,21 +595,6 @@ procedure GNATCmd is ...@@ -853,21 +595,6 @@ procedure GNATCmd is
Including_RTS => True); Including_RTS => True);
end Ensure_Absolute_Path; 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 -- -- Output_Version --
-------------------- --------------------
...@@ -881,9 +608,8 @@ procedure GNATCmd is ...@@ -881,9 +608,8 @@ procedure GNATCmd is
end if; end if;
Put_Line (Gnatvsn.Gnat_Version_String); Put_Line (Gnatvsn.Gnat_Version_String);
Put_Line ("Copyright 1996-" & Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
Gnatvsn.Current_Year & & ", Free Software Foundation, Inc.");
", Free Software Foundation, Inc.");
end Output_Version; end Output_Version;
----------- -----------
...@@ -899,9 +625,6 @@ procedure GNATCmd is ...@@ -899,9 +625,6 @@ procedure GNATCmd is
for C in Command_List'Range loop for C in Command_List'Range loop
-- No usage for Sync
if C /= Sync then
if Targparm.AAMP_On_Target then if Targparm.AAMP_On_Target then
Put ("gnaampcmd "); Put ("gnaampcmd ");
else else
...@@ -910,14 +633,7 @@ procedure GNATCmd is ...@@ -910,14 +633,7 @@ procedure GNATCmd is
Put (To_Lower (Command_List (C).Cname.all)); Put (To_Lower (Command_List (C).Cname.all));
Set_Col (25); Set_Col (25);
-- Never call gnatstack with a prefix
if C = Stack then
Put (Command_List (C).Unixcmd.all);
else
Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
end if;
declare declare
Sws : Argument_List_Access renames Command_List (C).Unixsws; Sws : Argument_List_Access renames Command_List (C).Unixsws;
...@@ -931,13 +647,12 @@ procedure GNATCmd is ...@@ -931,13 +647,12 @@ procedure GNATCmd is
end; end;
New_Line; New_Line;
end if;
end loop; end loop;
New_Line; New_Line;
Put_Line ("All commands except chop, krunch and preprocess " & Put_Line ("Commands bind, find, link, list and xref "
"accept project file switches -vPx, -Pprj, -Xnam=val," & & "accept project file switches -vPx, -Pprj, -Xnam=val,"
"--subdirs= and -eL"); & "--subdirs= and -eL");
New_Line; New_Line;
end Usage; end Usage;
...@@ -956,8 +671,8 @@ procedure GNATCmd is ...@@ -956,8 +671,8 @@ procedure GNATCmd is
Skip_Executable : Boolean := False; Skip_Executable : Boolean := False;
begin begin
-- Add the default search directories, to be able to find -- Add the default search directories, to be able to find libgnat in
-- libgnat in call to MLib.Utl.Lib_Directory. -- call to MLib.Utl.Lib_Directory.
Add_Default_Search_Dirs; Add_Default_Search_Dirs;
...@@ -1013,9 +728,8 @@ procedure GNATCmd is ...@@ -1013,9 +728,8 @@ procedure GNATCmd is
else else
-- First, compute the exact length for the switch -- First, compute the exact length for the switch
for Index in for Index in Library_Paths.First .. Library_Paths.Last loop
Library_Paths.First .. Library_Paths.Last
loop
-- Add the length of the library dir plus one for the -- Add the length of the library dir plus one for the
-- directory separator. -- directory separator.
...@@ -1038,27 +752,23 @@ procedure GNATCmd is ...@@ -1038,27 +752,23 @@ procedure GNATCmd is
loop loop
Option Option
(Current + 1 .. (Current + 1 ..
Current + Current + Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index).all; Library_Paths.Table (Index).all;
Current := Current :=
Current + Current + Library_Paths.Table (Index)'Length + 1;
Library_Paths.Table (Index)'Length + 1;
Option (Current) := Path_Separator; Option (Current) := Path_Separator;
end loop; end loop;
-- Finally put the standard GNAT library dir -- Finally put the standard GNAT library dir
Option Option
(Current + 1 .. (Current + 1 .. Current + MLib.Utl.Lib_Directory'Length) :=
Current + MLib.Utl.Lib_Directory'Length) :=
MLib.Utl.Lib_Directory; MLib.Utl.Lib_Directory;
-- And add the switch to the last switches -- And add the switch to the last switches
Last_Switches.Increment_Last; Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) := Last_Switches.Table (Last_Switches.Last) := Option;
Option;
end if; end if;
end; end;
end if; end if;
...@@ -1087,8 +797,7 @@ procedure GNATCmd is ...@@ -1087,8 +797,7 @@ procedure GNATCmd is
else else
declare declare
Switch : constant String := Switch : constant String := Last_Switches.Table (J).all;
Last_Switches.Table (J).all;
ALI_File : constant String (1 .. Switch'Length + 4) := ALI_File : constant String (1 .. Switch'Length + 4) :=
Switch & ".ali"; Switch & ".ali";
...@@ -1138,10 +847,8 @@ procedure GNATCmd is ...@@ -1138,10 +847,8 @@ procedure GNATCmd is
Dir : constant String := Dir : constant String :=
Get_Name_String (Prj.Object_Directory.Name); Get_Name_String (Prj.Object_Directory.Name);
begin begin
if Is_Regular_File if Is_Regular_File (Dir & ALI_File (1 .. Last)) then
(Dir &
ALI_File (1 .. Last))
then
-- We have found the correct project, so we -- We have found the correct project, so we
-- replace the file with the absolute path. -- replace the file with the absolute path.
...@@ -1170,8 +877,7 @@ procedure GNATCmd is ...@@ -1170,8 +877,7 @@ procedure GNATCmd is
for J in reverse 1 .. Last_Switches.Last - 1 loop for J in reverse 1 .. Last_Switches.Last - 1 loop
if Last_Switches.Table (J).all = "-o" then if Last_Switches.Table (J).all = "-o" then
Check_Relative_Executable Check_Relative_Executable (Name => Last_Switches.Table (J + 1));
(Name => Last_Switches.Table (J + 1));
Look_For_Executable := False; Look_For_Executable := False;
exit; exit;
end if; end if;
...@@ -1235,8 +941,7 @@ procedure GNATCmd is ...@@ -1235,8 +941,7 @@ procedure GNATCmd is
is is
pragma Unreferenced (Tree); pragma Unreferenced (Tree);
Path_Option : constant String_Access := Path_Option : constant String_Access := MLib.Linker_Library_Path_Option;
MLib.Linker_Library_Path_Option;
begin begin
-- Case of library project -- Case of library project
...@@ -1269,8 +974,7 @@ procedure GNATCmd is ...@@ -1269,8 +974,7 @@ procedure GNATCmd is
end if; end if;
end Set_Library_For; end Set_Library_For;
procedure Check_Version_And_Help is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
new Check_Version_And_Help_G (Usage);
-- Start of processing for GNATCmd -- Start of processing for GNATCmd
...@@ -1333,12 +1037,9 @@ begin ...@@ -1333,12 +1037,9 @@ begin
if Command (Index) = Directory_Separator then if Command (Index) = Directory_Separator then
declare declare
Absolute_Dir : constant String := Absolute_Dir : constant String :=
Normalize_Pathname Normalize_Pathname (Command (Command'First .. Index));
(Command (Command'First .. Index));
PATH : constant String := PATH : constant String :=
Absolute_Dir & Path_Separator & Getenv ("PATH").all; Absolute_Dir & Path_Separator & Getenv ("PATH").all;
begin begin
Setenv ("PATH", PATH); Setenv ("PATH", PATH);
end; end;
...@@ -1391,8 +1092,7 @@ begin ...@@ -1391,8 +1092,7 @@ begin
Alternate : Alternate_Command; Alternate : Alternate_Command;
begin begin
Alternate := Alternate_Command'Value Alternate := Alternate_Command'Value (Argument (Command_Arg));
(Argument (Command_Arg));
The_Command := Corresponding_To (Alternate); The_Command := Corresponding_To (Alternate);
exception exception
...@@ -1422,8 +1122,7 @@ begin ...@@ -1422,8 +1122,7 @@ begin
-- Open the file and fail if the file cannot be found -- Open the file and fail if the file cannot be found
begin begin
Open Open (Arg_File, In_File,
(Arg_File, In_File,
The_Arg (The_Arg'First + 1 .. The_Arg'Last)); The_Arg (The_Arg'First + 1 .. The_Arg'Last));
exception exception
...@@ -1456,8 +1155,7 @@ begin ...@@ -1456,8 +1155,7 @@ begin
-- the Last_Switches table. -- the Last_Switches table.
Last_Switches.Increment_Last; Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) := Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
new String'(The_Arg);
end if; end if;
end; end;
end loop; end loop;
...@@ -1506,8 +1204,8 @@ begin ...@@ -1506,8 +1204,8 @@ begin
end loop; end loop;
end if; end if;
-- For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB, -- For BIND, FIND, LINK, LIST and XREF, look for project file related
-- SYNC and XREF, look for project file related switches. -- switches.
case The_Command is case The_Command is
when Bind => when Bind =>
...@@ -1522,12 +1220,6 @@ begin ...@@ -1522,12 +1220,6 @@ begin
when List => when List =>
Tool_Package_Name := Name_Gnatls; Tool_Package_Name := Name_Gnatls;
Packages_To_Check := Packages_To_Check_By_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 => when Xref =>
Tool_Package_Name := Name_Cross_Reference; Tool_Package_Name := Name_Cross_Reference;
Packages_To_Check := Packages_To_Check_By_Xref; Packages_To_Check := Packages_To_Check_By_Xref;
...@@ -1566,8 +1258,7 @@ begin ...@@ -1566,8 +1258,7 @@ begin
if Argv (Argv'First) = '-' then if Argv (Argv'First) = '-' then
if Argv'Length = 1 then if Argv'Length = 1 then
Fail Fail ("switch character cannot be followed by a blank");
("switch character cannot be followed by a blank");
end if; end if;
-- The two style project files (-p and -P) cannot be used -- The two style project files (-p and -P) cannot be used
...@@ -1593,8 +1284,7 @@ begin ...@@ -1593,8 +1284,7 @@ begin
then then
Subdirs := Subdirs :=
new String' new String'
(Argv (Argv (Argv'First + Makeutl.Subdirs_Option'Length ..
(Argv'First + Makeutl.Subdirs_Option'Length ..
Argv'Last)); Argv'Last));
Remove_Switch (Arg_Num); Remove_Switch (Arg_Num);
...@@ -1662,8 +1352,7 @@ begin ...@@ -1662,8 +1352,7 @@ begin
Fail Fail
(Argv.all (Argv.all
& ": second project file forbidden (first is """ & ": second project file forbidden (first is """
& Project_File.all & Project_File.all & """)");
& """)");
-- The two style project files (-p and -P) cannot be -- The two style project files (-p and -P) cannot be
-- used together. -- used together.
...@@ -1712,16 +1401,14 @@ begin ...@@ -1712,16 +1401,14 @@ begin
if not Check (Root_Environment.External, if not Check (Root_Environment.External,
Argv (Argv'First + 2 .. Argv'Last)) Argv (Argv'First + 2 .. Argv'Last))
then then
Fail (Argv.all Fail
& " is not a valid external assignment."); (Argv.all & " is not a valid external assignment.");
end if; end if;
Remove_Switch (Arg_Num); Remove_Switch (Arg_Num);
elsif elsif
(The_Command = Sync or else The_Command = List
The_Command = Stack or else
The_Command = List)
and then Argv'Length = 2 and then Argv'Length = 2
and then Argv (2) = 'U' and then Argv (2) = 'U'
then then
...@@ -1798,10 +1485,10 @@ begin ...@@ -1798,10 +1485,10 @@ begin
if Pkg /= No_Package then if Pkg /= No_Package then
Element := Project_Tree.Shared.Packages.Table (Pkg); Element := Project_Tree.Shared.Packages.Table (Pkg);
-- Packages Gnatls and Gnatstack have a single attribute -- Package Gnatls has a single attribute Switches, that is not
-- Switches, that is not an associative array. -- an associative array.
if The_Command = List or else The_Command = Stack then if The_Command = List then
The_Switches := The_Switches :=
Prj.Util.Value_Of Prj.Util.Value_Of
(Variable_Name => Snames.Name_Switches, (Variable_Name => Snames.Name_Switches,
...@@ -1823,7 +1510,6 @@ begin ...@@ -1823,7 +1510,6 @@ begin
if Last_Switches.Table (J) (1) /= '-' then if Last_Switches.Table (J) (1) /= '-' then
if Main = null then if Main = null then
Main := Last_Switches.Table (J); Main := Last_Switches.Table (J);
else else
Main := null; Main := null;
exit; exit;
...@@ -1883,7 +1569,6 @@ begin ...@@ -1883,7 +1569,6 @@ begin
declare declare
Switch : constant String := Switch : constant String :=
Get_Name_String (The_Switches.Value); Get_Name_String (The_Switches.Value);
begin begin
if Switch'Length > 0 then if Switch'Length > 0 then
First_Switches.Increment_Last; First_Switches.Increment_Last;
...@@ -1901,7 +1586,6 @@ begin ...@@ -1901,7 +1586,6 @@ begin
declare declare
Switch : constant String := Switch : constant String :=
Get_Name_String (The_String.Value); Get_Name_String (The_String.Value);
begin begin
if Switch'Length > 0 then if Switch'Length > 0 then
First_Switches.Increment_Last; First_Switches.Increment_Last;
...@@ -1933,189 +1617,6 @@ begin ...@@ -1933,189 +1617,6 @@ begin
-- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
-- a configuration pragmas file, if necessary. -- 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 if The_Command = Link then
Process_Link; Process_Link;
end if; end if;
...@@ -2146,17 +1647,10 @@ begin ...@@ -2146,17 +1647,10 @@ begin
end; end;
end if; end if;
-- For gnat sync with -U + a main, get the list of sources from the -- For gnat list, if no file has been put on the command line, call
-- closure and add them to the arguments. -- tool with all the sources of the main project.
-- 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.
if The_Command = Sync or else if The_Command = List then
The_Command = List or else
The_Command = Stack
then
Check_Files; Check_Files;
end if; end if;
end if; end if;
......
gcc/ada/prj-attr.adb
...@@ -326,12 +326,6 @@ package body Prj.Attr is ...@@ -326,12 +326,6 @@ package body Prj.Attr is
"Ladefault_switches#" & "Ladefault_switches#" &
"LbOswitches#" & "LbOswitches#" &
-- package Synchronize
"Psynchronize#" &
"Ladefault_switches#" &
"LbOswitches#" &
-- package Eliminate -- package Eliminate
"Peliminate#" & "Peliminate#" &
......
gcc/ada/s-linux-android.ads
...@@ -47,6 +47,7 @@ package System.Linux is ...@@ -47,6 +47,7 @@ package System.Linux is
subtype long is Interfaces.C.long; subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long; subtype suseconds_t is Interfaces.C.long;
subtype time_t is Interfaces.C.long; subtype time_t is Interfaces.C.long;
subtype clockid_t is Interfaces.C.int;
type timespec is record type timespec is record
tv_sec : time_t; tv_sec : time_t;
......
gcc/ada/s-osinte-aix.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -206,6 +206,11 @@ package System.OS_Interface is ...@@ -206,6 +206,11 @@ package System.OS_Interface is
tp : access timespec) return int; tp : access timespec) return int;
pragma Import (C, clock_gettime, "clock_gettime"); 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; function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration); pragma Inline (To_Duration);
......
gcc/ada/s-osinte-android.ads
...@@ -211,6 +211,11 @@ package System.OS_Interface is ...@@ -211,6 +211,11 @@ package System.OS_Interface is
(clock_id : clockid_t; (clock_id : clockid_t;
tp : access timespec) return int; 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; function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration); pragma Inline (To_Duration);
......
gcc/ada/s-osinte-darwin.adb
...@@ -129,6 +129,36 @@ package body System.OS_Interface is ...@@ -129,6 +129,36 @@ package body System.OS_Interface is
return Result; return Result;
end clock_gettime; 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 -- -- sched_yield --
----------------- -----------------
......
gcc/ada/s-osinte-darwin.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -189,6 +189,10 @@ package System.OS_Interface is ...@@ -189,6 +189,10 @@ package System.OS_Interface is
(clock_id : clockid_t; (clock_id : clockid_t;
tp : access timespec) return int; tp : access timespec) return int;
function clock_getres
(clock_id : clockid_t;
res : access timespec) return int;
function To_Duration (TS : timespec) return Duration; function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration); pragma Inline (To_Duration);
......
gcc/ada/s-osinte-freebsd.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -202,6 +202,11 @@ package System.OS_Interface is ...@@ -202,6 +202,11 @@ package System.OS_Interface is
type clockid_t is new int; 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 function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
tp : access timespec) tp : access timespec)
......
gcc/ada/s-osinte-mingw.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -53,6 +53,8 @@ package System.OS_Interface is ...@@ -53,6 +53,8 @@ package System.OS_Interface is
subtype int is Interfaces.C.int; subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long; subtype long is Interfaces.C.long;
subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
------------------- -------------------
-- General Types -- -- General Types --
------------------- -------------------
...@@ -104,6 +106,18 @@ package System.OS_Interface is ...@@ -104,6 +106,18 @@ package System.OS_Interface is
procedure kill (sig : Signal); procedure kill (sig : Signal);
pragma Import (C, kill, "raise"); 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 -- -- Threads --
------------- -------------
......
gcc/ada/s-osinte-solaris-posix.ads
...@@ -189,6 +189,11 @@ package System.OS_Interface is ...@@ -189,6 +189,11 @@ package System.OS_Interface is
type clockid_t is new int; 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 function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
tp : access timespec) return int; tp : access timespec) return int;
......
gcc/ada/s-taprop-linux.adb
...@@ -662,6 +662,7 @@ package body System.Task_Primitives.Operations is ...@@ -662,6 +662,7 @@ package body System.Task_Primitives.Operations is
function RT_Resolution return Duration is function RT_Resolution return Duration is
TS : aliased timespec; TS : aliased timespec;
Result : int; Result : int;
begin begin
Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
......
gcc/ada/s-taprop-mingw.adb
...@@ -1076,8 +1076,10 @@ package body System.Task_Primitives.Operations is ...@@ -1076,8 +1076,10 @@ package body System.Task_Primitives.Operations is
------------------- -------------------
function RT_Resolution return Duration is function RT_Resolution return Duration is
Ticks_Per_Second : aliased LARGE_INTEGER;
begin begin
return 0.000_001; -- 1 micro-second QueryPerformanceFrequency (Ticks_Per_Second'Access);
return Duration (1.0 / Ticks_Per_Second);
end RT_Resolution; end RT_Resolution;
---------------- ----------------
......
gcc/ada/s-taprop-posix.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -743,8 +743,13 @@ package body System.Task_Primitives.Operations is ...@@ -743,8 +743,13 @@ package body System.Task_Primitives.Operations is
------------------- -------------------
function RT_Resolution return Duration is function RT_Resolution return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
begin 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; end RT_Resolution;
------------ ------------
......
gcc/ada/s-taprop-solaris.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -785,8 +785,13 @@ package body System.Task_Primitives.Operations is ...@@ -785,8 +785,13 @@ package body System.Task_Primitives.Operations is
------------------- -------------------
function RT_Resolution return Duration is function RT_Resolution return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
begin 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; end RT_Resolution;
----------- -----------
......
gcc/ada/s-tassta.adb
...@@ -989,7 +989,7 @@ package body System.Tasking.Stages is ...@@ -989,7 +989,7 @@ package body System.Tasking.Stages is
return; return;
end if; end if;
Initialization.Defer_Abort (Self_ID); Initialization.Defer_Abort_Nestable (Self_ID);
-- Loop through the From chain, changing their Master_of_Task fields, -- Loop through the From chain, changing their Master_of_Task fields,
-- and to find the end of the chain. -- and to find the end of the chain.
...@@ -1009,7 +1009,7 @@ package body System.Tasking.Stages is ...@@ -1009,7 +1009,7 @@ package body System.Tasking.Stages is
From.all.T_ID := null; From.all.T_ID := null;
Initialization.Undefer_Abort (Self_ID); Initialization.Undefer_Abort_Nestable (Self_ID);
end Move_Activation_Chain; end Move_Activation_Chain;
------------------ ------------------
...@@ -2011,9 +2011,9 @@ package body System.Tasking.Stages is ...@@ -2011,9 +2011,9 @@ package body System.Tasking.Stages is
(Self_ID.Deferral_Level > 0 (Self_ID.Deferral_Level > 0
or else not System.Restrictions.Abort_Allowed); or else not System.Restrictions.Abort_Allowed);
pragma Assert (Self_ID = Self); pragma Assert (Self_ID = Self);
pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 pragma Assert
or else (Self_ID.Master_Within in
Self_ID.Master_Within = Self_ID.Master_of_Task + 2); Self_ID.Master_of_Task + 1 .. Self_ID.Master_of_Task + 3);
pragma Assert (Self_ID.Common.Wait_Count = 0); pragma Assert (Self_ID.Common.Wait_Count = 0);
pragma Assert (Self_ID.Open_Accepts = null); pragma Assert (Self_ID.Open_Accepts = null);
pragma Assert (Self_ID.ATC_Nesting_Level = 1); pragma Assert (Self_ID.ATC_Nesting_Level = 1);
......
gcc/ada/sem_ch6.adb
...@@ -2094,6 +2094,14 @@ package body Sem_Ch6 is ...@@ -2094,6 +2094,14 @@ package body Sem_Ch6 is
elsif Is_Tagged_Type (Typ) then elsif Is_Tagged_Type (Typ) then
null; 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 elsif Nkind (Parent (N)) = N_Subprogram_Body
or else Nkind_In (Parent (Parent (N)), N_Accept_Statement, or else Nkind_In (Parent (Parent (N)), N_Accept_Statement,
N_Entry_Body) N_Entry_Body)
......
gcc/ada/thread.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -54,3 +54,35 @@ __gnat_pthread_condattr_setup (void *attr) { ...@@ -54,3 +54,35 @@ __gnat_pthread_condattr_setup (void *attr) {
} }
#endif #endif
#if defined (__APPLE__)
#include <mach/mach.h>
#include <mach/clock.h>
#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;
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment