[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:
parent
7504523eca
commit
fc3a3580da
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
------------
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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)));
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
Loading…
Reference in New Issue