From fc3a3580dad5f061d1ac645ddb8b0c78889d10a8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 12 Oct 2016 14:33:50 +0200 Subject: [PATCH] [multiple changes] 2016-10-12 Jerome Lambourg * init.c: Make sure to call finit on x86_64-vx7 to reinitialize the FPU unit. 2016-10-12 Arnaud Charlet * lib-load.adb (Load_Unit): Generate an error message even when Error_Node is null. 2016-10-12 Ed Schonberg * lib-writ.adb (Write_ALI): Disable optimization related to transitive limited_with clauses for now. 2016-10-12 Javier Miranda * 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 * 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 * 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 * 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 * 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 --- gcc/ada/ChangeLog | 57 +++++++++++++++++++++++++++ gcc/ada/a-tags.adb | 94 +++++++++++++++++++++++++++++--------------- gcc/ada/init.c | 4 +- gcc/ada/lib-load.adb | 8 ++-- gcc/ada/lib-writ.adb | 14 ++++++- gcc/ada/s-rident.ads | 2 - gcc/ada/sem_attr.adb | 38 ++++++++++++------ gcc/ada/sem_ch3.adb | 7 ++-- gcc/ada/sem_ch9.adb | 1 + gcc/ada/sem_res.adb | 9 +++++ 10 files changed, 179 insertions(+), 55 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 37ab195c5bb..fd49a21e1e1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,60 @@ +2016-10-12 Jerome Lambourg + + * init.c: Make sure to call finit on x86_64-vx7 to reinitialize + the FPU unit. + +2016-10-12 Arnaud Charlet + + * lib-load.adb (Load_Unit): Generate an error message even when + Error_Node is null. + +2016-10-12 Ed Schonberg + + * lib-writ.adb (Write_ALI): Disable optimization related to transitive + limited_with clauses for now. + +2016-10-12 Javier Miranda + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 * exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 203d19ed676..07c2139851c 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -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; ------------ diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 114310dd5a0..e180f3cfb09 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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 diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 83d3576eeb6..c66fd7264d2 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -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 diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index c5f9d01c932..b78e3eb3855 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index ab234c304fe..8f552ba9001 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -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))); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index c0be95d525a..cd7691f2136 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 07f25dcf846..2bd90717435 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 8297db8fe74..7ccf38bdb33 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f35c9e25145..47a67257051 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; -- 2.30.2