diff mbox series

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

Message ID 20190820095127.GA75542@adacore.com
State New
Headers show
Series [Ada] Spurious error in dispatching call with class-wide precondition | expand

Commit Message

Pierre-Marie de Rodat Aug. 20, 2019, 9:51 a.m. UTC 
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.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
diff mbox series

Patch

--- gcc/ada/exp_disp.adb
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;