From bc38dbb42271b6bdbc5e2e55200266aa5917f4bd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 13 Nov 2015 14:08:51 +0100 Subject: [PATCH] [multiple changes] 2015-11-13 Hristian Kirtchev * exp_ch9.adb, exp_fixd.adb, exp_util.adb, g-debpoo.adb, impunit.adb, scos.ads, sem_ch4.adb, sem_prag.adb, s-stchop-vxworks.adb: Minor reformatting. 2015-11-13 Tristan Gingold * s-rident.ads (Profile_Info): Enable Pure_Barriers for GNAT_Extended_Ravenscar. 2015-11-13 Bob Duff * sem_ch6.adb (Check_Private_Overriding): Detect the special case where the overriding subprogram is overriding a subprogram that was declared in the same private part. From-SVN: r230314 --- gcc/ada/ChangeLog | 17 ++++ gcc/ada/exp_ch9.adb | 41 +++++----- gcc/ada/exp_fixd.adb | 35 ++++---- gcc/ada/exp_util.adb | 2 +- gcc/ada/g-debpoo.adb | 151 +++++++++++++++++------------------ gcc/ada/impunit.adb | 6 +- gcc/ada/s-rident.ads | 2 +- gcc/ada/s-stchop-vxworks.adb | 11 +-- gcc/ada/scos.ads | 2 +- gcc/ada/sem_ch4.adb | 38 ++++----- gcc/ada/sem_ch6.adb | 18 ++++- gcc/ada/sem_prag.adb | 81 ++++++++++--------- 12 files changed, 222 insertions(+), 182 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 37a3fd31d89..d34ba295968 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2015-11-13 Hristian Kirtchev + + * exp_ch9.adb, exp_fixd.adb, exp_util.adb, g-debpoo.adb, + impunit.adb, scos.ads, sem_ch4.adb, sem_prag.adb, + s-stchop-vxworks.adb: Minor reformatting. + +2015-11-13 Tristan Gingold + + * s-rident.ads (Profile_Info): Enable Pure_Barriers for + GNAT_Extended_Ravenscar. + +2015-11-13 Bob Duff + + * sem_ch6.adb (Check_Private_Overriding): Detect the special + case where the overriding subprogram is overriding a subprogram + that was declared in the same private part. + 2015-11-13 Gary Dismukes * exp_ch9.adb: Minor reformatting and typo fixes. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d31eb62f226..80057627936 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6370,18 +6370,20 @@ package body Exp_Ch9 is function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is Renamed : Node_Id; - begin - if not Expander_Active then - return Scope (Entity (N)) = Current_Scope; + begin -- Check for case of _object.all.field (note that the explicit -- dereference gets inserted by analyze/expand of _object.field). - else + if Expander_Active then Renamed := Renamed_Object (Entity (N)); - return Present (Renamed) - and then Nkind (Renamed) = N_Selected_Component - and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; + + return + Present (Renamed) + and then Nkind (Renamed) = N_Selected_Component + and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; + else + return Scope (Entity (N)) = Current_Scope; end if; end Is_Simple_Barrier_Name; @@ -6392,19 +6394,18 @@ package body Exp_Ch9 is function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is begin case Nkind (N) is - when N_Identifier - | N_Expanded_Name => - + when N_Expanded_Name | + N_Identifier => if No (Entity (N)) then return Abandon; end if; case Ekind (Entity (N)) is - when E_Constant - | E_Discriminant - | E_Named_Integer - | E_Named_Real - | E_Enumeration_Literal => + when E_Constant | + E_Discriminant | + E_Named_Integer | + E_Named_Real | + E_Enumeration_Literal => return OK; when E_Variable => @@ -6416,13 +6417,13 @@ package body Exp_Ch9 is null; end case; - when N_Integer_Literal - | N_Real_Literal - | N_Character_Literal => + when N_Integer_Literal | + N_Real_Literal | + N_Character_Literal => return OK; - when N_Op_Boolean - | N_Op_Not => + when N_Op_Boolean | + N_Op_Not => if Ekind (Entity (N)) = E_Operator then return OK; end if; diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 78f8e724c4f..89aaf26ef44 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -1692,9 +1692,10 @@ package body Exp_Fixd is -- result cases, and faster. procedure Expand_Convert_Float_To_Fixed (N : Node_Id) is - Rng_Check : constant Boolean := Do_Range_Check (N); Expr : constant Node_Id := Expression (N); + Orig_N : constant Node_Id := Original_Node (N); Result_Type : constant Entity_Id := Etype (N); + Rng_Check : constant Boolean := Do_Range_Check (N); Small : constant Ureal := Small_Value (Result_Type); Truncate : Boolean; @@ -1704,27 +1705,31 @@ package body Exp_Fixd is if Small = Ureal_1 then Set_Result (N, Expr, Rng_Check, Trunc => True); - -- Normal case where multiply is required - -- Rounding is truncating for decimal fixed point types only, - -- see RM 4.6(29), except if the conversion comes from an attribute - -- reference 'Round (RM 3.5.10 (14)): The attribute is implemented - -- by means of a conversion that must round. + -- Normal case where multiply is required. Rounding is truncating + -- for decimal fixed point types only, see RM 4.6(29), except if the + -- conversion comes from an attribute reference 'Round (RM 3.5.10 (14)): + -- The attribute is implemented by means of a conversion that must + -- round. else if Is_Decimal_Fixed_Point_Type (Result_Type) then - Truncate := Nkind (Original_Node (N)) /= N_Attribute_Reference - or else Get_Attribute_Id (Attribute_Name (Original_Node (N))) - /= Attribute_Round; + Truncate := + Nkind (Orig_N) /= N_Attribute_Reference + or else Get_Attribute_Id + (Attribute_Name (Orig_N)) /= Attribute_Round; else Truncate := False; end if; - Set_Result (N, - Build_Multiply (N, - Fpt_Value (Expr), - Real_Literal (N, Ureal_1 / Small)), - Rng_Check, - Trunc => Truncate); + Set_Result + (N => N, + Expr => + Build_Multiply + (N => N, + L => Fpt_Value (Expr), + R => Real_Literal (N, Ureal_1 / Small)), + Rchk => Rng_Check, + Trunc => Truncate); end if; end Expand_Convert_Float_To_Fixed; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bd7b25ce54e..0b9543a6bea 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1672,8 +1672,8 @@ package body Exp_Util is function Containing_Package_With_Ext_Axioms (E : Entity_Id) return Entity_Id is + Decl : Node_Id; First_Ax_Parent_Scope : Entity_Id; - Decl : Node_Id; begin -- E is the package or generic package which is externally axiomatized diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 98243fd76c4..8ed8d0e277b 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -31,13 +31,13 @@ with GNAT.IO; use GNAT.IO; -with System.Address_Image; with System.CRTL; with System.Memory; use System.Memory; with System.Soft_Links; use System.Soft_Links; with System.Traceback_Entries; +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; with GNAT.HTable; with GNAT.Traceback; use GNAT.Traceback; @@ -226,8 +226,8 @@ package body GNAT.Debug_Pools is -- data, and does not include the header of that block. end record; - function Header_Of (Address : System.Address) - return Allocation_Header_Access; + function Header_Of + (Address : System.Address) return Allocation_Header_Access; pragma Inline (Header_Of); -- Return the header corresponding to a previously allocated address @@ -294,7 +294,7 @@ package body GNAT.Debug_Pools is -- up to the first one in the range: -- Ignored_Frame_Start .. Ignored_Frame_End - procedure Stdout_Put (S : String); + procedure Stdout_Put (S : String); -- Wrapper for Put that ensures we always write to stdout instead of the -- current output file defined in GNAT.IO. @@ -306,8 +306,7 @@ package body GNAT.Debug_Pools is (Output_File : File_Type; Prefix : String; Traceback : Traceback_Htable_Elem_Ptr); - -- Output Prefix & Traceback & EOL. - -- Print nothing if Traceback is null. + -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null. procedure Print_Address (File : File_Type; Addr : Address); -- Output System.Address without using secondary stack. @@ -479,37 +478,11 @@ package body GNAT.Debug_Pools is ------------------- procedure Print_Address (File : File_Type; Addr : Address) is - type My_Address is mod Memory_Size; - function To_My_Address is new Ada.Unchecked_Conversion - (System.Address, My_Address); - Address_To_Print : My_Address := To_My_Address (Addr); - type Hexadecimal_Element is range 0 .. 15; - Hexadecimal_Characters : constant array - (Hexadecimal_Element) of Character := - ('0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); - pragma Warnings - (Off, "types for unchecked conversion have different sizes"); - function To_Hexadecimal_Element is new Ada.Unchecked_Conversion - (My_Address, Hexadecimal_Element); - pragma Warnings - (On, "types for unchecked conversion have different sizes"); - Number_Of_Hexadecimal_Characters_In_Address : constant Natural := - Standard'Address_Size / 4; - type Hexadecimal_Elements_Range is - range 1 .. Number_Of_Hexadecimal_Characters_In_Address; - Hexadecimal_Elements : array (Hexadecimal_Elements_Range) of - Hexadecimal_Element; begin - for Index in Hexadecimal_Elements_Range loop - Hexadecimal_Elements (Index) := - To_Hexadecimal_Element (Address_To_Print mod 16); - Address_To_Print := Address_To_Print / 16; - end loop; - Put (File, "0x"); - for Index in reverse Hexadecimal_Elements_Range loop - Put (File, Hexadecimal_Characters (Hexadecimal_Elements (Index))); - end loop; + -- Warning: secondary stack cannot be used here. When System.Memory + -- implementation uses Debug_Pool, Print_Address can be called during + -- secondary stack creation for foreign threads. + Put (File, Image_C (Addr)); end Print_Address; -------------- @@ -544,14 +517,20 @@ package body GNAT.Debug_Pools is begin if Traceback = null then declare - Tr : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); - Start, Len : Natural; + Len : Natural; + Start : Natural; + Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); begin - Call_Chain (Tr, Len); - Skip_Levels (Depth, Tr, Start, Len, - Ignored_Frame_Start, Ignored_Frame_End); - Print (Tr (Start .. Len)); + Call_Chain (Trace, Len); + Skip_Levels + (Depth => Depth, + Trace => Trace, + Start => Start, + Len => Len, + Ignored_Frame_Start => Ignored_Frame_Start, + Ignored_Frame_End => Ignored_Frame_End); + Print (Trace (Start .. Len)); end; else @@ -613,16 +592,24 @@ package body GNAT.Debug_Pools is declare Disable_Exit_Value : constant Boolean := Disable; - Trace : aliased Tracebacks_Array - (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels); - Len, Start : Natural; + Elem : Traceback_Htable_Elem_Ptr; + Len : Natural; + Start : Natural; + Trace : aliased Tracebacks_Array + (1 .. Integer (Pool.Stack_Trace_Depth) + + Max_Ignored_Levels); begin Disable := True; Call_Chain (Trace, Len); - Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len, - Ignored_Frame_Start, Ignored_Frame_End); + Skip_Levels + (Depth => Pool.Stack_Trace_Depth, + Trace => Trace, + Start => Start, + Len => Len, + Ignored_Frame_Start => Ignored_Frame_Start, + Ignored_Frame_End => Ignored_Frame_End); -- Check if the traceback is already in the table @@ -632,14 +619,16 @@ package body GNAT.Debug_Pools is -- If not, insert it if Elem = null then - Elem := new Traceback_Htable_Elem' - (Traceback => new Tracebacks_Array'(Trace (Start .. Len)), - Count => 1, - Kind => Kind, - Total => Byte_Count (Size), - Frees => 0, - Total_Frees => 0, - Next => null); + Elem := + new Traceback_Htable_Elem' + (Traceback => + new Tracebacks_Array'(Trace (Start .. Len)), + Count => 1, + Kind => Kind, + Total => Byte_Count (Size), + Frees => 0, + Total_Frees => 0, + Next => null); Backtrace_Htable.Set (Elem); else @@ -674,10 +663,10 @@ package body GNAT.Debug_Pools is Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; Max_Validity_Byte_Index : constant := - Memory_Chunk_Size / Validity_Divisor; + Memory_Chunk_Size / Validity_Divisor; - subtype Validity_Byte_Index is Integer_Address - range 0 .. Max_Validity_Byte_Index - 1; + subtype Validity_Byte_Index is + Integer_Address range 0 .. Max_Validity_Byte_Index - 1; type Byte is mod 2 ** System.Storage_Unit; @@ -833,15 +822,20 @@ package body GNAT.Debug_Pools is if Allow_Unhandled_Memory then if Ptr.Handled = No_Validity_Bits_Part then Ptr.Handled := - To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); - Memset (Ptr.Handled.all'Address, 0, - size_t (Max_Validity_Byte_Index)); + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Memset + (A => Ptr.Handled.all'Address, + C => 0, + N => size_t (Max_Validity_Byte_Index)); end if; + Ptr.Handled (Offset / System.Storage_Unit) := - Ptr.Handled (Offset / System.Storage_Unit) or Bit; + Ptr.Handled (Offset / System.Storage_Unit) or Bit; end if; end Set_Handled; + -- Start of processing for Set_Valid + begin if Ptr = No_Validity_Bits then @@ -851,10 +845,12 @@ package body GNAT.Debug_Pools is if Value then Ptr := new Validity_Bits; Ptr.Valid := - To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); Validy_Htable.Set (Block_Number, Ptr); - Memset (Ptr.Valid.all'Address, 0, - size_t (Max_Validity_Byte_Index)); + Memset + (A => Ptr.Valid.all'Address, + C => 0, + N => size_t (Max_Validity_Byte_Index)); Ptr.Valid (Offset / System.Storage_Unit) := Bit; Set_Handled; end if; @@ -870,7 +866,6 @@ package body GNAT.Debug_Pools is end if; end if; end Set_Valid; - end Validity; -------------- @@ -883,7 +878,6 @@ package body GNAT.Debug_Pools is Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is - pragma Unreferenced (Alignment); -- Ignored, we always force Storage_Alignment @@ -926,7 +920,7 @@ package body GNAT.Debug_Pools is -- which is expensive. if Pool.Logically_Deallocated > - Byte_Count (Pool.Maximum_Logically_Freed_Memory) + Byte_Count (Pool.Maximum_Logically_Freed_Memory) then Free_Physically (Pool); end if; @@ -967,8 +961,9 @@ package body GNAT.Debug_Pools is -- For the purpose of computing Storage_Address, we just do as if the -- header was located first, followed by the alignment padding: - Storage_Address := To_Address - (Align (To_Integer (P.all'Address) + Integer_Address (Header_Offset))); + Storage_Address := + To_Address (Align (To_Integer (P.all'Address) + + Integer_Address (Header_Offset))); -- Computation is done in Integer_Address, not Storage_Offset, because -- the range of Storage_Offset may not be large enough. @@ -977,9 +972,13 @@ package body GNAT.Debug_Pools is pragma Assert (Storage_Address + Size_In_Storage_Elements <= P.all'Address + P'Length); - Trace := Find_Or_Create_Traceback - (Pool, Alloc, Size_In_Storage_Elements, - Allocate_Label'Address, Code_Address_For_Allocate_End); + Trace := + Find_Or_Create_Traceback + (Pool => Pool, + Kind => Alloc, + Size => Size_In_Storage_Elements, + Ignored_Frame_Start => Allocate_Label'Address, + Ignored_Frame_End => Code_Address_For_Allocate_End); pragma Warnings (Off); -- Turn warning on alignment for convert call off. We know that in fact @@ -1846,7 +1845,7 @@ package body GNAT.Debug_Pools is Byte_Count'Image (Data.Total) & ") "); for T in Data.Traceback'Range loop - Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' '); + Put (Image_C (PC_For (Data.Traceback (T))) & ' '); end loop; Put_Line (""); @@ -1872,7 +1871,7 @@ package body GNAT.Debug_Pools is if Header.Alloc_Traceback /= null then for T in Header.Alloc_Traceback.Traceback'Range loop - Put ("0x" & Address_Image + Put (Image_C (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); end loop; end if; @@ -2010,7 +2009,7 @@ package body GNAT.Debug_Pools is end; for J in Max (M).Traceback'Range loop - Put (" 0x" & Address_Image (PC_For (Max (M).Traceback (J)))); + Put (Image_C (PC_For (Max (M).Traceback (J)))); end loop; New_Line; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index e7d86d2faa5..62947b4f078 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -649,8 +649,8 @@ package body Impunit is -- Ada/System/Interfaces are all Ada 95 units if File = "ada.ads" - or else File = "system.ads" or else File = "interfac.ads" + or else File = "system.ads" then return Ada_95_Unit; end if; @@ -726,9 +726,9 @@ package body Impunit is -- Only remaining special possibilities are children of System.RPC and -- System.Garlic and special files of the form System.Aux... - if File (1 .. 5) = "s-rpc" + if File (1 .. 5) = "s-aux" or else File (1 .. 5) = "s-gar" - or else File (1 .. 5) = "s-aux" + or else File (1 .. 5) = "s-rpc" then return Ada_95_Unit; end if; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 66aa10e9038..f8ecb674301 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -543,7 +543,7 @@ package System.Rident is No_Select_Statements => True, No_Specific_Termination_Handlers => True, No_Task_Termination => True, - Simple_Barriers => True, + Pure_Barriers => True, others => False), -- Value settings for Ravenscar (same as Restricted) diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb index 106d4e6ed57..8afa535a643 100644 --- a/gcc/ada/s-stchop-vxworks.adb +++ b/gcc/ada/s-stchop-vxworks.adb @@ -131,15 +131,16 @@ package body System.Stack_Checking.Operations is Get_Stack_Info (Stack_Info'Access); if Stack_Grows_Down then - Limit := Stack_Info.Base - Storage_Offset (Stack_Info.Size) - + Storage_Offset'(16#12_000#); + Limit := + Stack_Info.Base - Storage_Offset (Stack_Info.Size) + + Storage_Offset'(16#12_000#); else - Limit := Stack_Info.Base + Storage_Offset (Stack_Info.Size) - - Storage_Offset'(16#12_000#); + Limit := + Stack_Info.Base + Storage_Offset (Stack_Info.Size) - + Storage_Offset'(16#12_000#); end if; Stack_Limit := Limit; - end Set_Stack_Limit_For_Current_Task; end System.Stack_Checking.Operations; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 2acce02ea19..da5cc47c5ad 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -361,7 +361,7 @@ package SCOs is end record; No_Source_Location : constant Source_Location := - (No_Line_Number, No_Column_Number); + (No_Line_Number, No_Column_Number); type SCO_Table_Entry is record From : Source_Location := No_Source_Location; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1b14550ba74..999a78bd36a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2192,9 +2192,9 @@ package body Sem_Ch4 is Get_Next_Interp (I, It); end loop; - -- If no valid interpretation has been found, then the type of - -- the ELSE expression does not match any interpretation of - -- the THEN expression. + -- If no valid interpretation has been found, then the type of the + -- ELSE expression does not match any interpretation of the THEN + -- expression. if Etype (N) = Any_Type then Error_Msg_N @@ -4665,10 +4665,11 @@ package body Sem_Ch4 is and then not Is_Entity_Name (Name) and then Nkind (Name) /= N_Explicit_Dereference then - Error_Msg_NE ("invalid reference to internal operation " - & "of some object of type&", N, Type_To_Use); + Error_Msg_NE + ("invalid reference to internal operation of some object of " + & "type &", N, Type_To_Use); Set_Entity (Sel, Any_Id); - Set_Etype (Sel, Any_Type); + Set_Etype (Sel, Any_Type); return; end if; @@ -4676,9 +4677,7 @@ package body Sem_Ch4 is -- visible entities are plausible interpretations, check whether -- there is some other primitive operation with that name. - if Ada_Version >= Ada_2005 - and then Is_Tagged_Type (Prefix_Type) - then + if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then if (Etype (N) = Any_Type or else not Has_Candidate) and then Try_Object_Operation (N) @@ -4710,13 +4709,12 @@ package body Sem_Ch4 is if Has_Candidate and then Is_Concurrent_Type (Prefix_Type) and then Nkind (Parent (N)) = N_Procedure_Call_Statement - + then -- Duplicate the call. This is required to avoid problems with -- the tree transformations performed by Try_Object_Operation. -- Set properly the parent of the copied call, because it is -- about to be reanalyzed. - then declare Par : constant Node_Id := New_Copy_Tree (Parent (N)); @@ -7305,20 +7303,16 @@ package body Sem_Ch4 is Nam : constant Entity_Id := Current_Entity (Sel); begin - if Present (Nam) - and then Is_Overloadable (Nam) - then - if Nkind (Parent (Parent (Par))) - = N_Procedure_Call_Statement + if Present (Nam) and then Is_Overloadable (Nam) then + if Nkind (Parent (Parent (Par))) = + N_Procedure_Call_Statement then return False; - else - if Ekind (Nam) = E_Function - and then Present (First_Formal (Nam)) - then - return Ekind (First_Formal (Nam)) = E_In_Parameter; - end if; + elsif Ekind (Nam) = E_Function + and then Present (First_Formal (Nam)) + then + return Ekind (First_Formal (Nam)) = E_In_Parameter; end if; end if; end; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a9a1a57dbfd..abc125680a7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8759,6 +8759,11 @@ package body Sem_Ch6 is -- True if S overrides a function in the visible part. The -- overridden function could be explicitly or implicitly declared. + function Parent_Is_Private return Boolean; + -- This detects the special case where the overriding subprogram + -- is overriding a subprogram that was declared in the same + -- private part. That case is illegal by 3.9.3(10). + function Overrides_Visible_Function (Partial_View : Entity_Id) return Boolean is @@ -8797,6 +8802,14 @@ package body Sem_Ch6 is return False; end Overrides_Visible_Function; + function Parent_Is_Private return Boolean is + S_Decl : constant Node_Id := Parent (Parent (S)); + Overridden_Decl : constant Node_Id := + Parent (Parent (Overridden_Operation (S))); + begin + return In_Same_List (Overridden_Decl, S_Decl); + end Parent_Is_Private; + -- Start of processing for Check_Private_Overriding begin @@ -8808,10 +8821,11 @@ package body Sem_Ch6 is if Is_Abstract_Type (T) and then Is_Abstract_Subprogram (S) and then (not Is_Overriding - or else not Is_Abstract_Subprogram (E)) + or else not Is_Abstract_Subprogram (E) + or else Parent_Is_Private) then Error_Msg_N ("abstract subprograms must be visible " - & "(RM 3.9.3(10))!", S); + & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function then declare diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9e873745e70..9a67e260052 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9660,11 +9660,6 @@ package body Sem_Prag is -- No_Dependence => System.Multiprocessors.Dispatching_Domains procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is - Prefix_Entity : Entity_Id; - Selector_Entity : Entity_Id; - Prefix_Node : Node_Id; - Node : Node_Id; - procedure Set_Error_Msg_To_Profile_Name; -- Set Error_Msg_String and Error_Msg_Strlen to the name of the -- profile. @@ -9674,16 +9669,26 @@ package body Sem_Prag is ----------------------------------- procedure Set_Error_Msg_To_Profile_Name is - Pragma_Args : constant List_Id := - Pragma_Argument_Associations (N); - Profile_Name : constant Node_Id := - Get_Pragma_Arg (First (Pragma_Args)); + Prof_Nam : constant Node_Id := + Get_Pragma_Arg + (First (Pragma_Argument_Associations (N))); + begin - Get_Name_String (Chars (Profile_Name)); - Adjust_Name_Case (Sloc (Profile_Name)); + Get_Name_String (Chars (Prof_Nam)); + Adjust_Name_Case (Sloc (Prof_Nam)); Error_Msg_Strlen := Name_Len; Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); end Set_Error_Msg_To_Profile_Name; + + -- Local variables + + Nod : Node_Id; + Pref : Node_Id; + Pref_Id : Node_Id; + Sel_Id : Node_Id; + + -- Start of processing for Set_Ravenscar_Profile + begin -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) @@ -9747,52 +9752,56 @@ package body Sem_Prag is -- No_Dependence => Ada.Execution_Time.Group_Budget -- No_Dependence => Ada.Execution_Time.Timers + -- ??? The use of Name_Buffer here is suspicious. The names should + -- be registered in snames.ads-tmpl and used to build the qualified + -- names of units. + if Ada_Version >= Ada_2005 then Name_Buffer (1 .. 3) := "ada"; Name_Len := 3; - Prefix_Entity := Make_Identifier (Loc, Name_Find); + Pref_Id := Make_Identifier (Loc, Name_Find); Name_Buffer (1 .. 14) := "execution_time"; Name_Len := 14; - Selector_Entity := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find); - Prefix_Node := + Pref := Make_Selected_Component (Sloc => Loc, - Prefix => Prefix_Entity, - Selector_Name => Selector_Entity); + Prefix => Pref_Id, + Selector_Name => Sel_Id); Name_Buffer (1 .. 13) := "group_budgets"; Name_Len := 13; - Selector_Entity := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find); - Node := + Nod := Make_Selected_Component (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + Prefix => Pref, + Selector_Name => Sel_Id); Set_Restriction_No_Dependence - (Unit => Node, + (Unit => Nod, Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); Name_Buffer (1 .. 6) := "timers"; Name_Len := 6; - Selector_Entity := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find); - Node := + Nod := Make_Selected_Component (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + Prefix => Pref, + Selector_Name => Sel_Id); Set_Restriction_No_Dependence - (Unit => Node, + (Unit => Nod, Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); end if; @@ -9805,32 +9814,32 @@ package body Sem_Prag is Name_Buffer (1 .. 6) := "system"; Name_Len := 6; - Prefix_Entity := Make_Identifier (Loc, Name_Find); + Pref_Id := Make_Identifier (Loc, Name_Find); Name_Buffer (1 .. 15) := "multiprocessors"; Name_Len := 15; - Selector_Entity := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find); - Prefix_Node := + Pref := Make_Selected_Component (Sloc => Loc, - Prefix => Prefix_Entity, - Selector_Name => Selector_Entity); + Prefix => Pref_Id, + Selector_Name => Sel_Id); Name_Buffer (1 .. 19) := "dispatching_domains"; Name_Len := 19; - Selector_Entity := Make_Identifier (Loc, Name_Find); + Sel_Id := Make_Identifier (Loc, Name_Find); - Node := + Nod := Make_Selected_Component (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + Prefix => Pref, + Selector_Name => Sel_Id); Set_Restriction_No_Dependence - (Unit => Node, + (Unit => Nod, Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); end if; -- 2.30.2