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 <schonb...@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.
Index: sem_aux.adb
===================================================================
--- sem_aux.adb (revision 247177)
+++ sem_aux.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- 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
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 247218)
+++ sem_ch13.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- 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;
