diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 77 | ||||
| -rw-r--r-- | gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 105 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/exp_unst.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/libgnarl/s-taprop__qnx.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-regexp.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 203 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 2 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/private_overriding.adb | 62 |
21 files changed, 376 insertions, 269 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 653d1e9..2619b16 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,80 @@ +2017-12-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Contains_Refined_State): Remove. + +2017-12-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications, case Predicate): A + predicate cannot apply to a formal type. + +2017-12-05 Arnaud Charlet <charlet@adacore.com> + + * exp_unst.ads: Fix typos. + +2017-12-05 Jerome Lambourg <lambourg@adacore.com> + + * libgnarl/s-taprop__qnx.adb: Better detect priority ceiling bug in + QNX. At startup, the first mutex created has a non-zero ceiling + priority whatever its actual policy. This makes some tests fail + (c940013 for example). + +2017-12-05 Bob Duff <duff@adacore.com> + + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Call + Expand_Cleanup_Actions for N_Extended_Return_Statement. + * exp_ch7.adb (Expand_Cleanup_Actions): Handle + N_Extended_Return_Statement by transforming the statements into a + block, and (indirectly) calling Expand_Cleanup_Actions on the block. + It's too hard for Expand_Cleanup_Actions to operate directly on the + N_Extended_Return_Statement, because it has a different structure than + the other node kinds that Expand_Cleanup_Actions. + * exp_util.adb (Requires_Cleanup_Actions): Add support for + N_Extended_Return_Statement. Change "when others => return False;" to + "when others => raise ...;" so it's clear what nodes this function + handles. Use named notation where appropriate. + * exp_util.ads: Mark incorrect comment with ???. + +2017-12-05 Javier Miranda <miranda@adacore.com> + + * exp_ch9.adb (Install_Private_Data_Declarations): Add missing + Debug_Info_Needed decoration of internally generated discriminal + renaming declaration. + +2017-12-05 Arnaud Charlet <charlet@adacore.com> + + * exp_unst.adb (Unnest_Subprogram): Add handling of 'Access on + nested subprograms. + +2017-12-05 Sergey Rybin <rybin@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Add description of '--ignore' + option for gnatmetric, gnatpp, gnat2xml, and gnattest. + +2017-12-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Contains_Refined_State): Remove. + +2017-12-05 Piotr Trojanek <trojanek@adacore.com> + + * rtsfind.ads: Add new enumeration literals: RE_Clock_Time (for + Ada.Real_Time.Clock_Time) and RO_CA_Clock_Time (for + Ada.Calendar.Clock_Time). + +2017-12-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Is_Private_Overriding): If the candidate private + subprogram is overloaded, scan the list of homonyms in the same + scope, to find the inherited operation that may be overridden + by the candidate. + * exp_ch11.adb, exp_ch7.adb: Minor reformatting. + +2017-12-05 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Expand_N_Extended_Return_Statement): If the + Init_Assignment is rewritten, we need to set Assignment_OK on the new + node. Otherwise, we will get spurious errors when initializing via + assignment statement. + 2017-12-05 Hristian Kirtchev <kirtchev@adacore.com> * sem_elab.adb: Update the terminology and switch sections. diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 4efbbe0..912356a 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -1400,6 +1400,11 @@ Alternatively, you may run the script using the following command line: Each nonempty line should contain the name of an existing file. Several such switches may be specified simultaneously. + :switch:`--ignore={filename}` + Do not process the sources listed in a specified file. This option cannot + be used in incremental mode. + + :switch:`-q` Quiet @@ -2753,6 +2758,12 @@ Alternatively, you may run the script using the following command line: Several such switches may be specified simultaneously. + .. index:: --ignore (gnatmetric) + + :switch:`--ignore={filename}` + Do not process the sources listed in a specified file. + + .. index:: -j (gnatmetric) :switch:`-j{n}` @@ -3466,6 +3477,13 @@ Alternatively, you may run the script using the following command line: Several such switches may be specified simultaneously. + .. index:: --ignore (gnatpp) + + :switch:`--ignore={filename}` + Do not process the sources listed in a specified file. This option cannot + be used in incremental mode. + + .. index:: -j (gnatpp) :switch:`-j{n}` @@ -4294,6 +4312,11 @@ Alternatively, you may run the script using the following command line: Each nonempty line should contain the name of an existing file. Several such switches may be specified simultaneously. + .. index:: --ignore (gnattest) + + :switch:`--ignore={filename}` + Do not process the sources listed in a specified file. + .. index:: --RTS (gnattest) :switch:`--RTS={rts-path}` diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 03d7371..666e380 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1419,19 +1419,28 @@ package body Exp_Ch11 is return; end if; - -- Add clean up actions if required + -- Add cleanup actions if required. No cleanup actions are needed in + -- thunks associated with interfaces, because they only displace the + -- pointer to the object. For extended return statements, we need + -- cleanup actions if the Handled_Statement_Sequence contains generated + -- objects of controlled types, for example. We do not want to clean up + -- the return object. if not Nkind_In (Parent (N), N_Accept_Statement, N_Extended_Return_Statement, N_Package_Body) and then not Delay_Cleanups (Current_Scope) - - -- No cleanup action needed in thunks associated with interfaces - -- because they only displace the pointer to the object. - and then not Is_Thunk (Current_Scope) then Expand_Cleanup_Actions (Parent (N)); + + elsif Nkind (Parent (N)) = N_Extended_Return_Statement + and then Handled_Statement_Sequence (Parent (N)) = N + and then not Delay_Cleanups (Current_Scope) + then + pragma Assert (not Is_Thunk (Current_Scope)); + Expand_Cleanup_Actions (Parent (N)); + else Set_First_Real_Statement (N, First (Statements (N))); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8a3f390..43731c8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5370,6 +5370,10 @@ package body Exp_Ch6 is Rewrite (Name (Init_Assignment), Make_Explicit_Dereference (Loc, Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); + pragma Assert + (Assignment_OK + (Original_Node (Name (Init_Assignment)))); + Set_Assignment_OK (Name (Init_Assignment)); Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); @@ -7310,7 +7314,7 @@ package body Exp_Ch6 is begin -- ???For now, enable build-in-place for a very narrow set of -- controlled types. Change "if True" to "if False" to - -- experiment more controlled types. Eventually, we would + -- experiment with more controlled types. Eventually, we might -- like to enable build-in-place for all tagged types, all -- types that need finalization, and all caller-unknown-size -- types. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 713ba58..1127875 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -310,7 +310,7 @@ package body Exp_Ch7 is function Build_Cleanup_Statements (N : Node_Id; Additional_Cleanup : List_Id) return List_Id; - -- Create the clean up calls for an asynchronous call block, task master, + -- Create the cleanup calls for an asynchronous call block, task master, -- protected subprogram body, task allocation block or task body, or -- additional cleanup actions parked on a transient block. If the context -- does not contain the above constructs, the routine returns an empty @@ -479,7 +479,7 @@ package body Exp_Ch7 is return False; -- Do not consider C and C++ types since it is assumed that the non-Ada - -- side will handle their clean up. + -- side will handle their cleanup. elsif Convention (Desig_Typ) = Convention_C or else Convention (Desig_Typ) = Convention_CPP @@ -1554,8 +1554,8 @@ package body Exp_Ch7 is Jump_Alts := New_List; end if; - -- If the context requires additional clean up, the finalization - -- machinery is added after the clean up code. + -- If the context requires additional cleanup, the finalization + -- machinery is added after the cleanup code. if Acts_As_Clean then Finalizer_Stmts := Clean_Stmts; @@ -1784,7 +1784,7 @@ package body Exp_Ch7 is end if; -- Protect the statements with abort defer/undefer. This is only when - -- aborts are allowed and the clean up statements require deferral or + -- aborts are allowed and the cleanup statements require deferral or -- there are controlled objects to be finalized. Note that the abort -- defer/undefer pair does not require an extra block because each -- finalization exception is caught in its corresponding finalization @@ -1800,7 +1800,7 @@ package body Exp_Ch7 is -- The local exception does not need to be reraised for library-level -- finalizers. Note that this action must be carried out after object - -- clean up, secondary stack release and abort undeferral. Generate: + -- cleanup, secondary stack release, and abort undeferral. Generate: -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); @@ -1907,7 +1907,7 @@ package body Exp_Ch7 is Append_To (Spec_Decls, Fin_Spec); Analyze (Fin_Spec); - -- When the finalizer acts solely as a clean up routine, the body + -- When the finalizer acts solely as a cleanup routine, the body -- is inserted right after the spec. if Acts_As_Clean and not Has_Ctrl_Objs then @@ -4200,13 +4200,22 @@ package body Exp_Ch7 is ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is + pragma Assert + (Nkind_In (N, + N_Extended_Return_Statement, + N_Block_Statement, + N_Subprogram_Body, + N_Task_Body, + N_Entry_Body)); + Scop : constant Entity_Id := Current_Scope; Is_Asynchronous_Call : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); Is_Master : constant Boolean := - Nkind (N) /= N_Entry_Body + Nkind (N) /= N_Extended_Return_Statement + and then Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); Is_Protected_Subp_Body : constant Boolean := Nkind (N) = N_Subprogram_Body @@ -4301,6 +4310,62 @@ package body Exp_Ch7 is return; end if; + -- If we are generating expanded code for debugging purposes, use the + -- Sloc of the point of insertion for the cleanup code. The Sloc will be + -- updated subsequently to reference the proper line in .dg files. If we + -- are not debugging generated code, use No_Location instead, so that + -- no debug information is generated for the cleanup code. This makes + -- the behavior of the NEXT command in GDB monotonic, and makes the + -- placement of breakpoints more accurate. + + if Debug_Generated_Code then + Loc := Sloc (Scop); + else + Loc := No_Location; + end if; + + -- If an extended return statement contains something like + -- X := F (...); + -- where F is a build-in-place function call returning a controlled + -- type, then a temporary object will be implicitly declared as part of + -- the statement list, and this will need cleanup. In such cases, we + -- transform: + -- + -- return Result : T := ... do + -- <statements> -- possibly with handlers + -- end return; + -- + -- into: + -- + -- return Result : T := ... do + -- declare -- no declarations + -- begin + -- <statements> -- possibly with handlers + -- end; -- no handlers + -- end return; + -- + -- So Expand_Cleanup_Actions will end up being called recursively on the + -- block statement. + + if Nkind (N) = N_Extended_Return_Statement then + declare + Block : constant Node_Id := + Make_Block_Statement (Loc, + Declarations => Empty_List, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)); + begin + Set_Handled_Statement_Sequence + (N, Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Block))); + Analyze (Block); + end; + + -- Analysis of the block did all the work + + return; + end if; + if Needs_Custom_Cleanup then Cln := Cleanup_Actions (N); else @@ -4315,20 +4380,6 @@ package body Exp_Ch7 is Old_Poll : Boolean; begin - -- If we are generating expanded code for debugging purposes, use the - -- Sloc of the point of insertion for the cleanup code. The Sloc will - -- be updated subsequently to reference the proper line in .dg files. - -- If we are not debugging generated code, use No_Location instead, - -- so that no debug information is generated for the cleanup code. - -- This makes the behavior of the NEXT command in GDB monotonic, and - -- makes the placement of breakpoints more accurate. - - if Debug_Generated_Code then - Loc := Sloc (Scop); - else - Loc := No_Location; - end if; - -- Set polling off. The finalization and cleanup code is executed -- with aborts deferred. @@ -5207,10 +5258,10 @@ package body Exp_Ch7 is then Loc := Sloc (Obj_Decl); - -- Before generating the clean up code for the first transient + -- Before generating the cleanup code for the first transient -- object, create a wrapper block which houses all hook clear -- statements and finalization calls. This wrapper is needed by - -- the back-end. + -- the back end. if not Built then Built := True; @@ -8680,10 +8731,10 @@ package body Exp_Ch7 is -- Finalizer; -- end; - -- A special case is made for Boolean expressions so that the back-end + -- A special case is made for Boolean expressions so that the back end -- knows to generate a conditional branch instruction, if running with - -- -fpreserve-control-flow. This ensures that a control flow change - -- signalling the decision outcome occurs before the cleanup actions. + -- -fpreserve-control-flow. This ensures that a control-flow change + -- signaling the decision outcome occurs before the cleanup actions. if Opt.Suppress_Control_Flow_Optimizations and then Is_Boolean_Type (Typ) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 621891d..cd260b2 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -13450,6 +13450,12 @@ package body Exp_Ch9 is Selector_Name => Make_Identifier (Loc, Chars (D)))); Add (Decl); + -- Set debug info needed on this renaming declaration even + -- though it does not come from source, so that the debugger + -- will get the right information for these generated names. + + Set_Debug_Info_Needed (Discriminal (D)); + Next_Discriminant (D); end loop; end; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 063b60f..9e5465b 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -574,6 +574,38 @@ package body Exp_Unst is end if; end if; + -- Record a 'Access as a (potential) call + + elsif Nkind (N) = N_Attribute_Reference then + declare + Attr : constant Attribute_Id := + Get_Attribute_Id (Attribute_Name (N)); + begin + case Attr is + when Attribute_Access + | Attribute_Unchecked_Access + | Attribute_Unrestricted_Access + => + Ent := Entity (Prefix (N)); + + -- We are only interested in calls to subprograms + -- nested within Subp. + + if Scope_Within (Ent, Subp) then + if Is_Imported (Ent) then + null; + + elsif Is_Subprogram (Ent) then + Append_Unique_Call + ((N, Current_Subprogram, Ent)); + end if; + end if; + + when others => + null; + end case; + end; + -- Record a subprogram. We record a subprogram body that acts as -- a spec. Otherwise we record a subprogram declaration, providing -- that it has a corresponding body we can get hold of. The case @@ -1616,7 +1648,9 @@ package body Exp_Unst is Act : Node_Id; begin - if Present (STT.ARECnF) then + if Present (STT.ARECnF) + and then Nkind (CTJ.N) /= N_Attribute_Reference + then -- CTJ.N is a call to a subprogram which may require a pointer -- to an activation record. The subprogram containing the call diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 1b7de11..3cd7496 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -64,7 +64,7 @@ package Exp_Unst is -- doing transformations of this type. -- Second: given that the transformation will be semantics-preserving, - -- we can still used the standard GCC back end to build code from it. + -- we can still use the standard GCC back end to build code from it. -- This means we can easily run our full test suite to verify that the -- transformations are indeed semantics preserving. It is a lot more -- work to thoroughly test the output of specialized back ends. @@ -239,7 +239,7 @@ package Exp_Unst is -- procedure inner (bb : integer; AREC1F : AREC1PT) is -- begin -- Integer'Deref(AREC1F.x) := - -- Integer'Deref(AREC1F.rv) + y + b + Integer_Deref(AREC1F.b); + -- Integer'Deref(AREC1F.rv) + y + b + Integer'Deref(AREC1F.b); -- end; -- -- begin @@ -658,7 +658,7 @@ package Exp_Unst is ARECnU : Entity_Id; -- This AREC entity is the uplink component. It is other than Empty only -- for nested subprograms that declare an activation record as indicated - -- by Declares_AREC being Ture, and which have uplevel references (Lev + -- by Declares_AREC being True, and which have uplevel references (Lev -- greater than Uplevel_Ref). It is the additional component in the -- activation record that references the ARECnF pointer (which points -- the activation record one level higher, thus forming the chain). diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c5e565b..b06e91a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10701,7 +10701,9 @@ package body Exp_Util is and then not Is_Empty_List (Then_Statements (N)) and then not Are_Wrapped (Then_Statements (N)) and then Requires_Cleanup_Actions - (Then_Statements (N), False, False) + (Then_Statements (N), + Lib_Level => False, + Nested_Constructs => False) then Block := Wrap_Statements_In_Block (Then_Statements (N)); Set_Then_Statements (N, New_List (Block)); @@ -10718,7 +10720,9 @@ package body Exp_Util is and then not Is_Empty_List (Else_Statements (N)) and then not Are_Wrapped (Else_Statements (N)) and then Requires_Cleanup_Actions - (Else_Statements (N), False, False) + (Else_Statements (N), + Lib_Level => False, + Nested_Constructs => False) then Block := Wrap_Statements_In_Block (Else_Statements (N)); Set_Else_Statements (N, New_List (Block)); @@ -10737,7 +10741,10 @@ package body Exp_Util is => if not Is_Empty_List (Statements (N)) and then not Are_Wrapped (Statements (N)) - and then Requires_Cleanup_Actions (Statements (N), False, False) + and then Requires_Cleanup_Actions + (Statements (N), + Lib_Level => False, + Nested_Constructs => False) then if Nkind (N) = N_Loop_Statement and then Present (Identifier (N)) @@ -11815,24 +11822,38 @@ package body Exp_Util is | N_Task_Body => return - Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True) + Requires_Cleanup_Actions + (Declarations (N), At_Lib_Level, Nested_Constructs => True) or else (Present (Handled_Statement_Sequence (N)) and then Requires_Cleanup_Actions (Statements (Handled_Statement_Sequence (N)), - At_Lib_Level, True)); + At_Lib_Level, Nested_Constructs => True)); + + -- Extended return statements are the same as the above, except that + -- there is no Declarations field. We do not want to clean up the + -- Return_Object_Declarations. + + when N_Extended_Return_Statement => + return + Present (Handled_Statement_Sequence (N)) + and then Requires_Cleanup_Actions + (Statements (Handled_Statement_Sequence (N)), + At_Lib_Level, Nested_Constructs => True); when N_Package_Specification => return Requires_Cleanup_Actions - (Visible_Declarations (N), At_Lib_Level, True) + (Visible_Declarations (N), At_Lib_Level, + Nested_Constructs => True) or else Requires_Cleanup_Actions - (Private_Declarations (N), At_Lib_Level, True); + (Private_Declarations (N), At_Lib_Level, + Nested_Constructs => True); when others => - return False; + raise Program_Error; end case; end Requires_Cleanup_Actions; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 3fab6dd..0b37789 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -52,7 +52,9 @@ package Exp_Util is -- For an expression occurring in a declaration (declarations always -- appear in lists), the actions are similarly inserted into the list - -- just before the associated declaration. + -- just before the associated declaration. ???Declarations do not always + -- appear in lists; in particular, a library unit declaration does not + -- appear in a list, and Insert_Action will crash in that case. -- The following special cases arise: diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index 4ec0330..e5133b7 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -442,16 +442,15 @@ package body System.Task_Primitives.Operations is -- Workaround bug in QNX on ceiling locks: tasks with priority higher -- than the ceiling priority don't receive EINVAL upon trying to lock. - if Result = 0 then + if Result = 0 and then Locking_Policy = 'C' then Result := pthread_getschedparam (Self, Policy'Access, Sched'Access); pragma Assert (Result = 0); Result := pthread_mutex_getprioceiling (L.WO'Access, Ceiling'Access); pragma Assert (Result = 0); - -- Ceiling = 0 means no Ceiling Priority policy is set on this mutex - -- Else, Ceiling < current priority means Ceiling violation + -- Ceiling < current priority means Ceiling violation -- (otherwise the current priority == ceiling) - if Ceiling > 0 and then Ceiling < Sched.sched_curpriority then + if Ceiling < Sched.sched_curpriority then Ceiling_Violation := True; Result := pthread_mutex_unlock (L.WO'Access); pragma Assert (Result = 0); diff --git a/gcc/ada/libgnat/s-regexp.ads b/gcc/ada/libgnat/s-regexp.ads index 0155b43..b399ca9 100644 --- a/gcc/ada/libgnat/s-regexp.ads +++ b/gcc/ada/libgnat/s-regexp.ads @@ -41,7 +41,7 @@ with Ada.Finalization; -package System.Regexp is +package System.Regexp is -- ???????????????? -- The regular expression must first be compiled, using the Compile -- function, which creates a finite state matching table, allowing diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 2a32b63..ccb00dc 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1445,7 +1445,7 @@ package Opt is -- GNAT.Exception_Traces is with'ed. Used to inhibit transformation of -- local raise statements into gotos in the presence of either package. - Sprint_Line_Limit : Nat := 72; + Sprint_Line_Limit : Nat := 72; -- ???????????????? -- GNAT -- Limit values for chopping long lines in Cprint/Sprint output, can be -- reset by use of NNN parameter with -gnatG or -gnatD switches. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 57b8897..72c48a8 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -543,6 +543,7 @@ package Rtsfind is RE_Null, RO_CA_Time, -- Ada.Calendar + RO_CA_Clock_Time, -- Ada.Calendar RO_CA_Delay_For, -- Ada.Calendar.Delays RO_CA_Delay_Until, -- Ada.Calendar.Delays @@ -582,6 +583,7 @@ package Rtsfind is RE_Names, -- Ada.Interrupts.Names RE_Clock, -- Ada.Real_Time + RE_Clock_Time, -- Ada.Real_Time RE_Time_Span, -- Ada.Real_Time RE_Time_Span_Zero, -- Ada.Real_Time RO_RT_Time, -- Ada.Real_Time @@ -1779,6 +1781,7 @@ package Rtsfind is RE_Null => RTU_Null, RO_CA_Time => Ada_Calendar, + RO_CA_Clock_Time => Ada_Calendar, RO_CA_Delay_For => Ada_Calendar_Delays, RO_CA_Delay_Until => Ada_Calendar_Delays, @@ -1818,6 +1821,7 @@ package Rtsfind is RE_Names => Ada_Interrupts_Names, RE_Clock => Ada_Real_Time, + RE_Clock_Time => Ada_Real_Time, RE_Time_Span => Ada_Real_Time, RE_Time_Span_Zero => Ada_Real_Time, RO_RT_Time => Ada_Real_Time, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b501e14..ebf1328 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2389,6 +2389,10 @@ package body Sem_Ch13 is elsif Is_Incomplete_Type (E) then Error_Msg_N ("predicate cannot apply to incomplete view", Aspect); + + elsif Is_Generic_Type (E) then + Error_Msg_N + ("predicate cannot apply to formal type", Aspect); goto Continue; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d13140f..5d760c2 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -9411,14 +9411,31 @@ package body Sem_Ch4 is --------------------------- function Is_Private_Overriding (Op : Entity_Id) return Boolean is - Visible_Op : constant Entity_Id := Homonym (Op); + Visible_Op : Entity_Id; begin - return Present (Visible_Op) - and then Scope (Op) = Scope (Visible_Op) - and then not Comes_From_Source (Visible_Op) - and then Alias (Visible_Op) = Op - and then not Is_Hidden (Visible_Op); + -- The subprogram may be overloaded with both visible and private + -- entities with the same name. We have to scan the chain of + -- homonyms to determine whether there is a previous implicit + -- declaration in the same scope that is overridden by the + -- private candidate. + + Visible_Op := Homonym (Op); + while Present (Visible_Op) loop + if Scope (Op) /= Scope (Visible_Op) then + return False; + + elsif not Comes_From_Source (Visible_Op) + and then Alias (Visible_Op) = Op + and then not Is_Hidden (Visible_Op) + then + return True; + end if; + + Visible_Op := Homonym (Visible_Op); + end loop; + + return False; end Is_Private_Overriding; ----------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 43e9ea2..ea2379c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5296,209 +5296,6 @@ package body Sem_Util is end if; end Conditional_Delay; - ---------------------------- - -- Contains_Refined_State -- - ---------------------------- - - function Contains_Refined_State (Prag : Node_Id) return Boolean is - function Has_State_In_Dependency (List : Node_Id) return Boolean; - -- Determine whether a dependency list mentions a state with a visible - -- refinement. - - function Has_State_In_Global (List : Node_Id) return Boolean; - -- Determine whether a global list mentions a state with a visible - -- refinement. - - function Is_Refined_State (Item : Node_Id) return Boolean; - -- Determine whether Item is a reference to an abstract state with a - -- visible refinement. - - ----------------------------- - -- Has_State_In_Dependency -- - ----------------------------- - - function Has_State_In_Dependency (List : Node_Id) return Boolean is - Clause : Node_Id; - Output : Node_Id; - - begin - -- A null dependency list does not mention any states - - if Nkind (List) = N_Null then - return False; - - -- Dependency clauses appear as component associations of an - -- aggregate. - - elsif Nkind (List) = N_Aggregate - and then Present (Component_Associations (List)) - then - Clause := First (Component_Associations (List)); - while Present (Clause) loop - - -- Inspect the outputs of a dependency clause - - Output := First (Choices (Clause)); - while Present (Output) loop - if Is_Refined_State (Output) then - return True; - end if; - - Next (Output); - end loop; - - -- Inspect the outputs of a dependency clause - - if Is_Refined_State (Expression (Clause)) then - return True; - end if; - - Next (Clause); - end loop; - - -- If we get here, then none of the dependency clauses mention a - -- state with visible refinement. - - return False; - - -- An illegal pragma managed to sneak in - - else - raise Program_Error; - end if; - end Has_State_In_Dependency; - - ------------------------- - -- Has_State_In_Global -- - ------------------------- - - function Has_State_In_Global (List : Node_Id) return Boolean is - Item : Node_Id; - - begin - -- A null global list does not mention any states - - if Nkind (List) = N_Null then - return False; - - -- Simple global list or moded global list declaration - - elsif Nkind (List) = N_Aggregate then - - -- The declaration of a simple global list appear as a collection - -- of expressions. - - if Present (Expressions (List)) then - Item := First (Expressions (List)); - while Present (Item) loop - if Is_Refined_State (Item) then - return True; - end if; - - Next (Item); - end loop; - - -- The declaration of a moded global list appears as a collection - -- of component associations where individual choices denote - -- modes. - - else - Item := First (Component_Associations (List)); - while Present (Item) loop - if Has_State_In_Global (Expression (Item)) then - return True; - end if; - - Next (Item); - end loop; - end if; - - -- If we get here, then the simple/moded global list did not - -- mention any states with a visible refinement. - - return False; - - -- Single global item declaration - - elsif Is_Entity_Name (List) then - return Is_Refined_State (List); - - -- An illegal pragma managed to sneak in - - else - raise Program_Error; - end if; - end Has_State_In_Global; - - ---------------------- - -- Is_Refined_State -- - ---------------------- - - function Is_Refined_State (Item : Node_Id) return Boolean is - Elmt : Node_Id; - Item_Id : Entity_Id; - - begin - if Nkind (Item) = N_Null then - return False; - - -- States cannot be subject to attribute 'Result. This case arises - -- in dependency relations. - - elsif Nkind (Item) = N_Attribute_Reference - and then Attribute_Name (Item) = Name_Result - then - return False; - - -- Multiple items appear as an aggregate. This case arises in - -- dependency relations. - - elsif Nkind (Item) = N_Aggregate - and then Present (Expressions (Item)) - then - Elmt := First (Expressions (Item)); - while Present (Elmt) loop - if Is_Refined_State (Elmt) then - return True; - end if; - - Next (Elmt); - end loop; - - -- If we get here, then none of the inputs or outputs reference a - -- state with visible refinement. - - return False; - - -- Single item - - else - Item_Id := Entity_Of (Item); - - return - Present (Item_Id) - and then Ekind (Item_Id) = E_Abstract_State - and then Has_Visible_Refinement (Item_Id); - end if; - end Is_Refined_State; - - -- Local variables - - Arg : constant Node_Id := - Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); - Nam : constant Name_Id := Pragma_Name (Prag); - - -- Start of processing for Contains_Refined_State - - begin - if Nam = Name_Depends then - return Has_State_In_Dependency (Arg); - - else pragma Assert (Nam = Name_Global); - return Has_State_In_Global (Arg); - end if; - end Contains_Refined_State; - ------------------------- -- Copy_Component_List -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c2d67f8e..c1f421f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -480,13 +480,6 @@ package Sem_Util is -- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is -- False). - function Contains_Refined_State (Prag : Node_Id) return Boolean; - -- Determine whether pragma Prag contains a reference to the entity of an - -- abstract state with a visible refinement. Prag must denote one of the - -- following pragmas: - -- Depends - -- Global - function Copy_Component_List (R_Typ : Entity_Id; Loc : Source_Ptr) return List_Id; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 0d8eb06..c523053 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -49,7 +49,7 @@ with System; with Unchecked_Conversion; with Unchecked_Deallocation; -package Types is +package Types is -- ???????????????? pragma Preelaborate; ------------------------------- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d040a77..b9b09d4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2017-12-05 Ed Schonberg <schonberg@adacore.com> + + * gnat.dg/private_overriding.adb: New testcase. + 2017-12-05 Martin Liska <mliska@suse.cz> Jakub Jelinek <jakub@redhat.com> diff --git a/gcc/testsuite/gnat.dg/private_overriding.adb b/gcc/testsuite/gnat.dg/private_overriding.adb new file mode 100644 index 0000000..0d59ae0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/private_overriding.adb @@ -0,0 +1,62 @@ +-- { dg-do compile } + +procedure Private_Overriding is + + package Foo is + + type Bar is abstract tagged null record; + + procedure Overloaded_Subprogram + (Self : in out Bar) + is abstract; + + procedure Overloaded_Subprogram + (Self : in out Bar; + P1 : Integer) + is abstract; + + procedure Not_Overloaded_Subprogram + (Self : in out Bar) + is abstract; + + + type Baz is new Bar with null record; + -- promise to override both overloaded subprograms, + -- shouldn't matter that they're defined in the private part, + + private -- workaround: override in the public view + + overriding + procedure Overloaded_Subprogram + (Self : in out Baz) + is null; + + overriding + procedure Overloaded_Subprogram + (Self : in out Baz; + P1 : Integer) + is null; + + overriding + procedure Not_Overloaded_Subprogram + (Self : in out Baz) + is null; + + end Foo; + + Qux : Foo.Baz; +begin + + -- this is allowed, as expected + Foo.Not_Overloaded_Subprogram(Qux); + Foo.Overloaded_Subprogram(Qux); + Foo.Overloaded_Subprogram(Foo.Baz'Class(Qux)); + Foo.Overloaded_Subprogram(Foo.Bar'Class(Qux)); + + -- however, using object-dot notation + Qux.Not_Overloaded_Subprogram; -- this is allowed + Qux.Overloaded_Subprogram; -- "no selector..." + Foo.Baz'Class(Qux).Overloaded_Subprogram; -- "no selector..." + Foo.Bar'Class(Qux).Overloaded_Subprogram; -- this is allowed + +end Private_Overriding; |