[Ada] Spurious error on predicate of subtype in generic

This patch fixes a spurious error on a dynamic predicate of a record
subtype when the expression for the predicate includes a selected
component that denotes a component of the subtype.

2019-07-03  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch8.adb (Find_Selected_Component): If the prefix is the
	current instance of a type or subtype, complete the resolution
	of the name by finding the component of the type denoted by the
	selector name.

gcc/testsuite/

	* gnat.dg/predicate4.adb, gnat.dg/predicate4_pkg.ads: New
	testcase.

From-SVN: r272961

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 96c16bd..b236063 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-03  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch8.adb (Find_Selected_Component): If the prefix is the
+       current instance of a type or subtype, complete the resolution
+       of the name by finding the component of the type denoted by the
+       selector name.
+
 2019-07-03  Eric Botcazou  <ebotcazou@adacore.com>
 
        * doc/gnat_rm/interfacing_to_other_languages.rst (Interfacing to C):

diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index a5e821d..8f2d245 100644 (file)
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -7418,10 +7418,28 @@ package body Sem_Ch8 is
 
             --  It is not an error if the prefix is the current instance of
             --  type name, e.g. the expression of a type aspect, when it is
-            --  analyzed for ASIS use.
+            --  analyzed for ASIS use, or within a generic unit. We still
+            --  have to verify that a component of that name exists, and
+            --  decorate the node accordingly.
 
             elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then
-               null;
+               declare
+                  Comp : Entity_Id;
+
+               begin
+                  Comp := First_Entity (Entity (P));
+                  while Present (Comp) loop
+                     if Chars (Comp) = Chars (Selector_Name (N)) then
+                        Set_Entity (N, Comp);
+                        Set_Etype  (N, Etype (Comp));
+                        Set_Entity (Selector_Name (N), Comp);
+                        Set_Etype  (Selector_Name (N), Etype (Comp));
+                        return;
+                     end if;
+
+                     Next_Entity (Comp);
+                  end loop;
+               end;
 
             elsif Ekind (P_Name) = E_Void then
                Premature_Usage (P);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b2c4cc3..925e8b7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-07-03  Ed Schonberg  <schonberg@adacore.com>
+
+       * gnat.dg/predicate4.adb, gnat.dg/predicate4_pkg.ads: New
+       testcase.
+
 2019-07-03  Jakub Jelinek  <jakub@redhat.com>
 
        * c-c++-common/gomp/scan-3.c (f1): Don't expect a sorry message.

diff --git a/gcc/testsuite/gnat.dg/predicate4.adb b/gcc/testsuite/gnat.dg/predicate4.adb
new file mode 100644 (file)
index 0000000..ce4ddf8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate4.adb
@@ -0,0 +1,19 @@
+--  { dg-do compile }
+--  { dg-options "-gnata" }
+
+with System.Assertions; use System.Assertions;
+with Predicate4_Pkg;
+procedure Predicate4 is
+   type V is new Float;
+   package MXI2 is new Predicate4_Pkg (V);
+   use MXI2;
+   OK : Lt := (Has => False);
+begin
+   declare
+      Wrong : Lt := (Has => True, MX => 3.14);
+   begin
+      raise Program_Error;
+   end;
+exception
+   when Assert_Failure => null;
+end;

diff --git a/gcc/testsuite/gnat.dg/predicate4_pkg.ads b/gcc/testsuite/gnat.dg/predicate4_pkg.ads
new file mode 100644 (file)
index 0000000..1b2e62d
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate4_pkg.ads
@@ -0,0 +1,16 @@
+generic
+   type Value_Type is private;
+package Predicate4_Pkg is
+  type MT (Has : Boolean := False) is record
+     case Has is
+        when False =>
+           null;
+        when True =>
+           MX : Value_Type;
+     end case;
+  end record;
+
+  function Foo (M : MT) return Boolean is (not M.Has);
+  subtype LT is MT with Dynamic_Predicate => not LT.Has;
+  function Bar (M : MT) return Boolean is (Foo (M));
+end;