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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-06-11 Ed Schonberg <schonb...@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.
--- gcc/ada/sem_ch13.adb
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;