===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1295,7 +1295,10 @@
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
- D : constant Node_Id := Declaration_Node (Typ);
+ D : constant Node_Id := Original_Node (Declaration_Node (Typ));
+ -- We use the original node of the declaration, because derived
+ -- types from record subtypes are rewritten as record declarations,
+ -- and it is the original declaration that carries the ancestor.
begin
-- If we have a subtype declaration, get the ancestor subtype
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -8309,11 +8309,15 @@
if Present (T) and then Present (Predicate_Function (T)) then
Set_Has_Predicates (Typ);
- -- Build the call to the predicate function of T
+ -- Build the call to the predicate function of T. The type may be
+ -- derived, so use an unchecked conversion for the actual.
Exp :=
Make_Predicate_Call
- (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
+ (Typ => T,
+ Expr =>
+ Unchecked_Convert_To (T,
+ Make_Identifier (Loc, Object_Name)));
-- "and"-in the call to evolving expression
@@ -8456,6 +8460,14 @@
begin
Ritem := First_Rep_Item (Typ);
+
+ -- If the type is private, check whether full view has inherited
+ -- predicates.
+
+ if Is_Private_Type (Typ) and then No (Ritem) then
+ Ritem := First_Rep_Item (Full_View (Typ));
+ end if;
+
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
@@ -8562,8 +8574,16 @@
-- ones for the current type, as required by AI12-0071-1.
declare
- Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+ Atyp : Entity_Id;
begin
+ Atyp := Nearest_Ancestor (Typ);
+
+ -- The type may be private but the full view may inherit predicates
+
+ if No (Atyp) and then Is_Private_Type (Typ) then
+ Atyp := Nearest_Ancestor (Full_View (Typ));
+ end if;
+
if Present (Atyp) then
Add_Call (Atyp);
end if;
This patch fixes an omission in the generation of predicate functions for private types whose full view derives from a subtype with predicates. Executing the following: gnatmake -gnata -q predicate_check predicate_check must yield; OK derived subtype OK original subtype --- with Text_IO; use Text_IO; with Ada.Assertions; use Ada.Assertions; procedure Predicate_Check with SPARK_Mode is type R is -- new Integer; record F : Integer := 42; end record; package Nested is subtype S is R with Predicate => S.F = 42; -- subtype S is R with Predicate => S = 42; procedure P (X : in out S) is null; type T is private; procedure P (X : in out T); private type T is new S; end Nested; package body Nested is procedure P (X : in out T) is begin X.F := X.F * 7; end; end Nested; X : Nested.T; Y : Nested.S; begin Y.F := Y.F * 3; begin Nested.P (X); Put_Line ("should not be here"); exception when Assertion_Error => Put_Line ("OK derived subtype"); end; begin Nested.P (Y); Put_Line ("should not be here"); exception when Assertion_Error => Put_Line ("OK original subtype"); end; end Predicate_Check; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Ed Schonberg <schonberg@adacore.com> * sem_aux.adb (Nearest_Ancestor): Use original node of type declaration to locate nearest ancestor, because derived type declarations for record types are rewritten as record declarations. * sem_ch13.adb (Add_Call): Use an unchecked conversion to handle properly derivations that are completions of private types. (Add_Predicates): If type is private, examine rep. items of full view, which may include inherited predicates. (Build_Predicate_Functions): Ditto.