Commit 1233757a by Ed Schonberg Committed by Pierre-Marie de Rodat

[Ada] Spurious error in dispatching call with class-wide precondition

This patch fixes a spurious visibility error on a dispatching call to
a subprogram with a classwide precondition, when the call qppears in
the same declarative part as the subprogram declaration itself.

2019-08-20  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_disp.adb (Build_Class_Wide_Check, Replace_Formals): When a
	dispatching call tp a subprogram with a class-wide precondition
	occurrs in the same declarative part as the ancestor subprogram
	being called, the`expression for the precondition has not been
	analyzed yet. Such a call may appear, e.g. in an expression
	function. In that case, the replacement of formals by actuals in
	the call cannot use the formal entities of the subprogram being
	called, and the occurrence of the formals in the expression must
	be located by name (Chars fields) as would be done at a later
	freeze point, when the expression is resolved in the context of
	the subprogram itself.

gcc/testsuite/

	* gnat.dg/tagged5.adb, gnat.dg/tagged5.ads: New testcase.

From-SVN: r274733
parent 9740c244
2019-08-20 Ed Schonberg <schonberg@adacore.com>
* exp_disp.adb (Build_Class_Wide_Check, Replace_Formals): When a
dispatching call tp a subprogram with a class-wide precondition
occurrs in the same declarative part as the ancestor subprogram
being called, the`expression for the precondition has not been
analyzed yet. Such a call may appear, e.g. in an expression
function. In that case, the replacement of formals by actuals in
the call cannot use the formal entities of the subprogram being
called, and the occurrence of the formals in the expression must
be located by name (Chars fields) as would be done at a later
freeze point, when the expression is resolved in the context of
the subprogram itself.
2019-08-20 Bob Duff <duff@adacore.com>
* sem_prag.adb (Persistent_BSS): If an initialization is present
......
......@@ -728,23 +728,27 @@ package body Exp_Disp is
-- corresponding actuals in the call, given that this check is
-- performed outside of the body of the subprogram.
-- If the dispatching call appears in the same scope as the
-- declaration of the dispatching subprogram (for example in
-- the expression of a local expression function) the prec.
-- has not been analyzed yet, in which case we use the Chars
-- field to recognize intended occurrences of the formals.
---------------------
-- Replace_Formals --
---------------------
function Replace_Formals (N : Node_Id) return Traverse_Result is
A : Node_Id;
F : Entity_Id;
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Formal (Entity (N))
then
declare
A : Node_Id;
F : Entity_Id;
if Is_Entity_Name (N) then
F := First_Formal (Subp);
A := First_Actual (Call_Node);
begin
F := First_Formal (Subp);
A := First_Actual (Call_Node);
if Present (Entity (N))
and then Is_Formal (Entity (N))
then
while Present (F) loop
if F = Entity (N) then
Rewrite (N, New_Copy_Tree (A));
......@@ -776,7 +780,25 @@ package body Exp_Disp is
Next_Formal (F);
Next_Actual (A);
end loop;
end;
-- If node is not analyzed, recognize occurrences of
-- a formal by name, as would be done when resolving
-- the aspect expression in the context of the subprogram.
elsif not Analyzed (N)
and then Nkind (N) = N_Identifier
and then No (Entity (N))
then
while Present (F) loop
if Chars (N) = Chars (F) then
Rewrite (N, New_Copy_Tree (A));
return Skip;
end if;
Next_Formal (F);
Next_Actual (A);
end loop;
end if;
end if;
return OK;
......
2019-08-20 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/tagged5.adb, gnat.dg/tagged5.ads: New testcase.
2019-08-20 Gary Dismukes <dismukes@adacore.com>
* gnat.dg/type_conv2.adb, gnat.dg/type_conv2.ads: New testcase.
......
-- { dg-do compile }
-- { dg-options "-gnata" }
package body Tagged5 is
procedure Dummy is null;
end Tagged5;
package Tagged5 is
type T is limited interface;
not overriding function Element
(Self : T;
Index : Positive)
return Integer is abstract
with Pre'Class => Index + Index ** 2 in 1 .. 10;
function First
(Self : T'Class)
return Integer
is (Self.Element (1));
procedure Dummy;
end Tagged5;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment