From 1233757a2dd3bf314aa308e51cbaeb6a512d59db Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 20 Aug 2019 09:49:56 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 14 ++++++++++ gcc/ada/exp_disp.adb | 44 +++++++++++++++++++++++-------- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/tagged5.adb | 6 +++++ gcc/testsuite/gnat.dg/tagged5.ads | 18 +++++++++++++ 5 files changed, 75 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/tagged5.adb create mode 100644 gcc/testsuite/gnat.dg/tagged5.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3cb30ef6448..fc32ef89eaf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2019-08-20 Ed Schonberg + + * 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 * 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 35fc4849203..84a6256681c 100644 --- 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 e53afce4540..629041b6f7f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-08-20 Ed Schonberg + + * gnat.dg/tagged5.adb, gnat.dg/tagged5.ads: New testcase. + 2019-08-20 Gary Dismukes * 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 index 00000000000..ffccca8779f --- /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 index 00000000000..3047269c88d --- /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; -- 2.30.2