This patch fixds a spurious error report on a prefixed call where the
operation is a private overriding of a visible operation, and the operation
has various overloadings in the visible and private parts.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-12-05 Ed Schonberg <schonb...@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.
gcc/testsuite/
2017-12-05 Ed Schonberg <schonb...@adacore.com>
* gnat.dg/private_overriding.adb: New testcase.
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 255412)
+++ exp_ch11.adb (working copy)
@@ -1419,19 +1419,28 @@
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;
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 255408)
+++ exp_ch7.adb (working copy)
@@ -310,7 +310,7 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
----------------------------
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 @@
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 @@
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 @@
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 @@
-- 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)
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 255408)
+++ sem_ch4.adb (working copy)
@@ -9411,14 +9411,31 @@
---------------------------
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;
-----------------
Index: ../testsuite/gnat.dg/private_overriding.adb
===================================================================
--- ../testsuite/gnat.dg/private_overriding.adb (revision 0)
+++ ../testsuite/gnat.dg/private_overriding.adb (revision 0)
@@ -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;
