From 20643f5032f7f3c11a233861e05f8efb4059e9dd Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 11 Jun 2018 09:19:02 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 6 +++++ gcc/ada/sem_ch13.adb | 16 ++++++++++- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/predicate1.adb | 40 ++++++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/predicate1.adb 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 + + * 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 * 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 + + * gnat.dg/predicate1.adb: New testcase. + 2018-06-11 Yannick Moy * 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; -- 2.30.2