OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-10-12  Jerome Lambourg  <lambourg@adacore.com>

	* init.c: Make sure to call finit on x86_64-vx7 to reinitialize
	the FPU unit.

2016-10-12  Arnaud Charlet  <charlet@adacore.com>

	* lib-load.adb (Load_Unit): Generate an error message even when
	Error_Node is null.

2016-10-12  Ed Schonberg  <schonberg@adacore.com>

	* lib-writ.adb (Write_ALI): Disable optimization related to transitive
	limited_with clauses for now.

2016-10-12  Javier Miranda  <miranda@adacore.com>

	* sem_attr.adb (Analyze_Attribute_Old_Result): Generating C
	code handle 'old located in inlined _postconditions procedures.
	(Analyze_Attribute [Attribute_Result]): Handle 'result when
	rewriting the attribute as a reference to the formal parameter
	_Result of inlined _postconditions procedures.

2016-10-12  Tristan Gingold  <gingold@adacore.com>

	* s-rident.ads (Profile_Info): Remove
	Max_Protected_Entries restriction from GNAT_Extended_Ravenscar
	* sem_ch9.adb (Analyze_Protected_Type_Declaration):
	Not a controlled type on restricted runtimes.

2016-10-12  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch3.adb (Derive_Subprogram): Add test
	for Is_Controlled of Parent_Type when determining whether an
	inherited subprogram with one of the special names Initialize,
	Adjust, or Finalize should be derived with its normal name even
	when inherited as a private operation (which would normally
	result in the inherited operation having a special "hidden" name).

2016-10-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Call): If a function call returns a
	limited view of a type replace it with the non-limited view,
	which must be available when compiling call.  This was already
	done elsewhere for non-overloaded calls, but needs to be done
	after resolution if function name is overloaded.

2016-10-12  Javier Miranda  <miranda@adacore.com>

	* a-tags.adb (IW_Membership [private]): new overloaded
	subprogram that factorizes the code needed to check if a
	given type implements an interface type.
	(IW_Membership
	[public]): invoke the new internal IW_Membership function.
	(Is_Descendant_At_Same_Level): Fix this routine to implement RM
	3.9 (12.3/3)

From-SVN: r241036
This commit is contained in:
Arnaud Charlet 2016-10-12 14:33:50 +02:00
parent 7504523eca
commit fc3a3580da
10 changed files with 179 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/ada/ChangeLog
View File

@ -1,3 +1,60 @@
2016-10-12 Jerome Lambourg <lambourg@adacore.com>
* init.c: Make sure to call finit on x86_64-vx7 to reinitialize
the FPU unit.
2016-10-12 Arnaud Charlet <charlet@adacore.com>
* lib-load.adb (Load_Unit): Generate an error message even when
Error_Node is null.
2016-10-12 Ed Schonberg <schonberg@adacore.com>
* lib-writ.adb (Write_ALI): Disable optimization related to transitive
limited_with clauses for now.
2016-10-12 Javier Miranda <miranda@adacore.com>
* sem_attr.adb (Analyze_Attribute_Old_Result): Generating C
code handle 'old located in inlined _postconditions procedures.
(Analyze_Attribute [Attribute_Result]): Handle 'result when
rewriting the attribute as a reference to the formal parameter
_Result of inlined _postconditions procedures.
2016-10-12 Tristan Gingold <gingold@adacore.com>
* s-rident.ads (Profile_Info): Remove
Max_Protected_Entries restriction from GNAT_Extended_Ravenscar
* sem_ch9.adb (Analyze_Protected_Type_Declaration):
Not a controlled type on restricted runtimes.
2016-10-12 Gary Dismukes <dismukes@adacore.com>
* sem_ch3.adb (Derive_Subprogram): Add test
for Is_Controlled of Parent_Type when determining whether an
inherited subprogram with one of the special names Initialize,
Adjust, or Finalize should be derived with its normal name even
when inherited as a private operation (which would normally
result in the inherited operation having a special "hidden" name).
2016-10-12 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Call): If a function call returns a
limited view of a type replace it with the non-limited view,
which must be available when compiling call. This was already
done elsewhere for non-overloaded calls, but needs to be done
after resolution if function name is overloaded.
2016-10-12 Javier Miranda <miranda@adacore.com>
* a-tags.adb (IW_Membership [private]): new overloaded
subprogram that factorizes the code needed to check if a
given type implements an interface type.
(IW_Membership
[public]): invoke the new internal IW_Membership function.
(Is_Descendant_At_Same_Level): Fix this routine to implement RM
3.9 (12.3/3)
2016-10-12 Tristan Gingold <gingold@adacore.com>
* exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support

94
gcc/ada/a-tags.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -61,6 +61,13 @@ package body Ada.Tags is
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
function IW_Membership
(Descendant_TSD : Type_Specific_Data_Ptr;
T : Tag) return Boolean;
-- Subsidiary function of IW_Membership and CW_Membership which factorizes
-- the functionality needed to check if a given descendant implements an
-- interface tag T.
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated). See comment in body
@ -431,27 +438,14 @@ package body Ada.Tags is
-- IW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Iface'Class
-- Each dispatch table contains a table with the tags of all the
-- implemented interfaces.
-- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership (This : System.Address; T : Tag) return Boolean is
function IW_Membership
(Descendant_TSD : Type_Specific_Data_Ptr;
T : Tag) return Boolean
is
Iface_Table : Interface_Data_Ptr;
Obj_Base : System.Address;
Obj_DT : Dispatch_Table_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
begin
Obj_Base := Base_Address (This);
Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
Iface_Table := Obj_TSD.Interfaces_Table;
Iface_Table := Descendant_TSD.Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
@ -464,8 +458,8 @@ package body Ada.Tags is
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
for Id in 0 .. Obj_TSD.Idepth loop
if Obj_TSD.Tags_Table (Id) = T then
for Id in 0 .. Descendant_TSD.Idepth loop
if Descendant_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
@ -473,6 +467,33 @@ package body Ada.Tags is
return False;
end IW_Membership;
-------------------
-- IW_Membership --
-------------------
-- Canonical implementation of Classwide Membership corresponding to:
-- Obj in Iface'Class
-- Each dispatch table contains a table with the tags of all the
-- implemented interfaces.
-- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
-- that are contained in the dispatch table referenced by Obj'Tag.
function IW_Membership (This : System.Address; T : Tag) return Boolean is
Obj_Base : System.Address;
Obj_DT : Dispatch_Table_Ptr;
Obj_TSD : Type_Specific_Data_Ptr;
begin
Obj_Base := Base_Address (This);
Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
return IW_Membership (Obj_TSD, T);
end IW_Membership;
-------------------
-- Expanded_Name --
-------------------
@ -721,18 +742,27 @@ package body Ada.Tags is
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
D_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
A_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
D_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
A_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
begin
return CW_Membership (Descendant, Ancestor)
and then D_TSD.Access_Level = A_TSD.Access_Level;
if Descendant = Ancestor then
return True;
else
declare
D_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
A_TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
D_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
A_TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
begin
return D_TSD.Access_Level = A_TSD.Access_Level
and then (CW_Membership (Descendant, Ancestor)
or else
IW_Membership (D_TSD, Ancestor));
end;
end if;
end Is_Descendant_At_Same_Level;
------------

4
gcc/ada/init.c
View File

@ -2138,9 +2138,9 @@ __gnat_init_float (void)
#endif
#endif
#if defined (__i386__) && !defined (VTHREADS)
#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
/* This is used to properly initialize the FPU on an x86 for each
process thread. Is this needed for x86_64 ??? */
process thread. */
asm ("finit");
#endif

8
gcc/ada/lib-load.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -784,7 +784,7 @@ package body Lib.Load is
-- Generate message if unit required
if Required and then Present (Error_Node) then
if Required then
if Is_Predefined_File_Name (Fname) then
-- This is a predefined library unit which is not present
@ -799,7 +799,9 @@ package body Lib.Load is
-- the message about the restriction violation is generated,
-- if needed.
Check_Restricted_Unit (Load_Name, Error_Node);
if Present (Error_Node) then
Check_Restricted_Unit (Load_Name, Error_Node);
end if;
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg -- CODEFIX

14
gcc/ada/lib-writ.adb
View File

@ -1440,9 +1440,21 @@ package body Lib.Writ is
-- in the context of the parent, and their file table entries are
-- not properly decorated, they are recognized syntactically.
if Present (Cunit_Entity (Unum))
-- This optimization is disabled when inline is active, because
-- inline may propose some bodies for inlining, and decide later
-- that they may lead to circularities, in which case they are
-- also left unanalyzed in the file table. There is no simple way
-- to distinguish between the two kinds of unanalyzed entries,
-- so simplest is to skip this step.
-- Actually, this optimization is always disabled, because it
-- breaks gnatfind.
if False -- ???
and then Present (Cunit_Entity (Unum))
and then Ekind (Cunit_Entity (Unum)) = E_Void
and then Nkind (Unit (Cunit (Unum))) /= N_Subunit
and then not Inline_Active
then
goto Next_Unit;
end if;

2
gcc/ada/s-rident.ads
View File

@ -563,7 +563,6 @@ package System.Rident is
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
@ -584,7 +583,6 @@ package System.Rident is
Value =>
(Max_Asynchronous_Select_Nesting => 0,
Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));

38
gcc/ada/sem_attr.adb
View File

@ -1358,13 +1358,23 @@ package body Sem_Attr is
-- appear on a subprogram renaming, when the renamed entity is an
-- attribute reference.
if not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
N_Entry_Declaration,
N_Generic_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Subprogram_Declaration,
N_Subprogram_Renaming_Declaration)
-- Generating C code the internally built nested _postcondition
-- subprograms are inlined; after expanded, inlined aspects are
-- located in the internal block generated by the frontend.
if Nkind (Subp_Decl) = N_Block_Statement
and then Modify_Tree_For_C
and then In_Inlined_Body
then
null;
elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
N_Entry_Declaration,
N_Generic_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Subprogram_Declaration,
N_Subprogram_Renaming_Declaration)
then
return;
end if;
@ -5276,6 +5286,9 @@ package body Sem_Attr is
-- Local variables
In_Inlined_C_Postcondition : constant Boolean :=
Modify_Tree_For_C and then In_Inlined_Body;
Legal : Boolean;
Pref_Id : Entity_Id;
Spec_Id : Entity_Id;
@ -5309,10 +5322,7 @@ package body Sem_Attr is
-- The exception to this rule is when generating C since in this case
-- postconditions are inlined.
if No (Spec_Id)
and then Modify_Tree_For_C
and then In_Inlined_Body
then
if No (Spec_Id) and then In_Inlined_C_Postcondition then
Spec_Id := Entity (P);
elsif not Legal then
@ -5325,7 +5335,11 @@ package body Sem_Attr is
-- Instead, rewrite the attribute as a reference to formal parameter
-- _Result of the _Postconditions procedure.
if Chars (Spec_Id) = Name_uPostconditions then
if Chars (Spec_Id) = Name_uPostconditions
or else
(In_Inlined_C_Postcondition
and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
then
Rewrite (N, Make_Identifier (Loc, Name_uResult));
-- The type of formal parameter _Result is that of the function

7
gcc/ada/sem_ch3.adb
View File

@ -14757,9 +14757,10 @@ package body Sem_Ch3 is
or else Is_Internal (Parent_Subp)
or else Is_Private_Overriding
or else Is_Internal_Name (Chars (Parent_Subp))
or else Nam_In (Chars (Parent_Subp), Name_Initialize,
Name_Adjust,
Name_Finalize)
or else (Is_Controlled (Parent_Type)
and then Nam_In (Chars (Parent_Subp), Name_Initialize,
Name_Adjust,
Name_Finalize))
then
Set_Derived_Name;

1
gcc/ada/sem_ch9.adb
View File

@ -2090,6 +2090,7 @@ package body Sem_Ch9 is
if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (T) > 1)
and then not Restricted_Profile
and then
(Has_Entries (T)
or else Has_Interrupt_Handler (T)

9
gcc/ada/sem_res.adb
View File

@ -6034,6 +6034,15 @@ package body Sem_Res is
end;
else
-- If the function returns the limited view of type, the call must
-- appear in a context in which the non-limited view is available.
-- As is done in Try_Object_Operation, use the available view to
-- prevent back-end confusion.
if From_Limited_With (Etype (Nam)) then
Set_Etype (Nam, Available_View (Etype (Nam)));
end if;
Set_Etype (N, Etype (Nam));
end if;