From: Ed Schonberg <schonberg@adacore.com>
Date: Mon, 11 Jun 2018 09:19:02 +0000 (+0000)
Subject: [Ada] Missing predicate function body for derived type in nested package
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=20643f5032f7f3c11a233861e05f8efb4059e9dd;p=gcc.git

[Ada] Missing predicate function body for derived type in nested package

This patch fixes a bug in the construction of predicate functions.  For a
derived type, we must ensure that the parent type is already frozen so that its
predicate function has been constructed already. This is necessary if the
parent is declared in a nested package and its own freeze point has not been
reached when the derived type is frozen by a local object declaration.

2018-06-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch13.adb (Build_Predicate_Functions): For a derived type, ensure
	that its parent is already frozen so that its predicate function, if
	any, has already been constructed.

gcc/testsuite/

	* gnat.dg/predicate1.adb: New testcase.

From-SVN: r261422
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 175d15d7069..2393bfaa0c6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-06-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb (Build_Predicate_Functions): For a derived type, ensure
+	that its parent is already frozen so that its predicate function, if
+	any, has already been constructed.
+
 2018-06-11  Yannick Moy  <moy@adacore.com>
 
 	* sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Adapt for
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index efa2709653a..ad9e9a140c9 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -11114,13 +11114,27 @@ package body Sem_Ch13 is
 
       --  If we have a type with predicates, build predicate function. This is
       --  not needed in the generic case, nor within TSS subprograms and other
-      --  predefined primitives.
+      --  predefined primitives. For a derived type, ensure that the parent
+      --  type is already frozen so that its predicate function has been
+      --  constructed already. This is necessary if the parent is declared
+      --  in a nested package and its own freeze point has not been reached.
 
       if Is_Type (E)
         and then Nongeneric_Case
         and then not Within_Internal_Subprogram
         and then Has_Predicates (E)
       then
+         declare
+            Atyp : constant Entity_Id := Nearest_Ancestor (E);
+         begin
+            if Present (Atyp)
+              and then Has_Predicates (Atyp)
+              and then not Is_Frozen (Atyp)
+            then
+               Freeze_Before (N, Atyp);
+            end if;
+         end;
+
          Build_Predicate_Functions (E, N);
       end if;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 111fdd0544f..7d088a1322c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-06-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/predicate1.adb: New testcase.
+
 2018-06-11  Yannick Moy  <moy@adacore.com>
 
 	* gnat.dg/spark1.adb, gnat.dg/spark1.ads: New testcase.
diff --git a/gcc/testsuite/gnat.dg/predicate1.adb b/gcc/testsuite/gnat.dg/predicate1.adb
new file mode 100644
index 00000000000..47b4dbf47b9
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate1.adb
@@ -0,0 +1,40 @@
+--  { dg-do run }
+--  { dg-options "-gnata" }
+
+procedure Predicate1 with SPARK_Mode is
+    type R is record
+       F : Integer;
+    end record;
+
+    package Nested is
+       subtype S is R with Predicate => S.F = 42;
+       procedure P (X : in out S) is null;
+
+       type T is private;
+       procedure P (X : in out T) is null;
+    private
+       type T is new S;
+    end Nested;
+
+    X : Nested.T;
+    Y : Nested.S;
+
+    X_Uninitialized : Boolean := False;
+    Y_Uninitialized : Boolean := False;
+begin
+   begin
+      Nested.P (X);
+   exception
+      when others => X_Uninitialized := True;
+   end;
+
+   begin
+      Nested.P (Y);
+   exception
+      when others => Y_Uninitialized := True;
+   end;
+
+   if not X_Uninitialized or else not Y_Uninitialized then
+      raise Program_Error;
+   end if;
+end Predicate1;