[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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@274733 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3cb30ef644808d2d98268874fcaa6e888c9c729a..fc32ef89eaf947859d03399cc21ceb6e6fa341ad 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+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

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 35fc4849203dd32e9eecf9b8e2cbf99a3e57bd79..84a6256681cc1e687c2cc55e83b0844660d07b9e 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e53afce4540c9129678210278d876aeb12cb4301..629041b6f7fbe1765ff89d2f2533aa22f398ea87 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gnat.dg/tagged5.adb b/gcc/testsuite/gnat.dg/tagged5.adb
new file mode 100644 (file)
index 0000000..ffccca8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/tagged5.adb
@@ -0,0 +1,6 @@
+--  { dg-do compile }
+--  { dg-options "-gnata" }
+
+package body Tagged5 is
+   procedure Dummy is null;
+end Tagged5;

diff --git a/gcc/testsuite/gnat.dg/tagged5.ads b/gcc/testsuite/gnat.dg/tagged5.ads
new file mode 100644 (file)
index 0000000..3047269
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/tagged5.ads
@@ -0,0 +1,18 @@
+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;