Commit 20643f50 by Ed Schonberg Committed by Pierre-Marie de Rodat

[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
parent 577b1ab4
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> 2018-06-11 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Adapt for * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Adapt for
......
...@@ -11114,13 +11114,27 @@ package body Sem_Ch13 is ...@@ -11114,13 +11114,27 @@ package body Sem_Ch13 is
-- If we have a type with predicates, build predicate function. This 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 -- 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) if Is_Type (E)
and then Nongeneric_Case and then Nongeneric_Case
and then not Within_Internal_Subprogram and then not Within_Internal_Subprogram
and then Has_Predicates (E) and then Has_Predicates (E)
then 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); Build_Predicate_Functions (E, N);
end if; end if;
......
2018-06-11 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/predicate1.adb: New testcase.
2018-06-11 Yannick Moy <moy@adacore.com> 2018-06-11 Yannick Moy <moy@adacore.com>
* gnat.dg/spark1.adb, gnat.dg/spark1.ads: New testcase. * gnat.dg/spark1.adb, gnat.dg/spark1.ads: New testcase.
......
-- { 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment