https://gcc.gnu.org/g:17bec6c53d41ce4510ae1b6bfa1e36beab6546d5
commit r16-1786-g17bec6c53d41ce4510ae1b6bfa1e36beab6546d5
Author: Steve Baird <ba...@adacore.com>
Date: Mon Apr 7 14:15:37 2025 -0700
ada: Fix Itype-related predicate check omissions.
Clean up problematic interactions between Itype subtypes and predicates,
which were causing required predicate checks to be (incorrectly) omitted.
gcc/ada/ChangeLog:
* einfo-utils.adb (Predicate_Function): Improve handling of a case
where a predicate specified for a subtype of a partial view of a
type was incorrectly ignored.
(Set_Predicate_Function): If the attribute has already been set to
the same value, then do nothing (instead of raising P_E).
* sem_ch13.adb (Build_Predicate_Function): Add new function
Has_Source_Predicate. If a subtype inherits a predicate but also
has its own explicitly specified predicate, then avoid
misinterpreting the presence of the function built for the
inherited predicate to mean that no additional predicate function
is needed.
* sem_util.adb (Build_Subtype): In the case where we are given a
constrained record or array subtype and we need to construct a
different subtype, subject to a different constraint, the
subtype_mark of the constructed subtype needs to reference an
unconstrained subtype (because a new constraint is going to be
imposed). If the Predicated_Parent attribute of the given subtype
is present and refers to a suitable unconstrained subtype, then
use that subtype instead of setting the Predicated_Parent
attribute on a new node (and performing the associated attribute
copying).
Diff:
---
gcc/ada/einfo-utils.adb | 40 +++++++++++++++++++++++++++++++++--
gcc/ada/sem_ch13.adb | 56 +++++++++++++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_util.adb | 25 +++++++++++++++++++++-
3 files changed, 118 insertions(+), 3 deletions(-)
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 91d273cb32d9..60ee509da674 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -2376,6 +2376,37 @@ package body Einfo.Utils is
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
+ -- We may have incorrectly looked through predicate-bearing
+ -- subtypes when going from a private subtype to its full
+ -- view, so compensate for that case. Unfortunately,
+ -- Subp_Id might not be analyzed at this point, so we
+ -- use a crude works-most-of-the-time text-based
+ -- test to detect the case where Id is a subtype (declared by
+ -- a subtype declaration) and no predicate was explicitly
+ -- specified for Id. Ugh. ???
+
+ if Nkind (Parent (Id)) = N_Subtype_Declaration
+ -- 1st choice ...
+ -- and then Etype (First_Entity (Subp_Id)) /= Id
+ -- but that doesn't work if Subp_Id is not analyzed.
+
+ -- so we settle for 2nd choice, ignoring cases like
+ -- "subtype Foo is Pkg.Foo;" where distinct subtypes
+ -- have the same identifier:
+ --
+ and then Get_Name_String (Chars (Subp_Id)) /=
+ Get_Name_String (Chars (Id)) & "Predicate"
+ then
+ declare
+ Mark : Node_Id := Subtype_Indication (Parent (Id));
+ begin
+ if Nkind (Mark) = N_Subtype_Indication then
+ Mark := Subtype_Mark (Mark);
+ end if;
+ return Predicate_Function (Entity (Mark));
+ end;
+ end if;
+
return Subp_Id;
end if;
@@ -2803,7 +2834,6 @@ package body Einfo.Utils is
end if;
Subp_Elmt := First_Elmt (Subps);
- Prepend_Elmt (V, Subps);
-- Check for a duplicate predication function
@@ -2813,11 +2843,17 @@ package body Einfo.Utils is
if Ekind (Subp_Id) = E_Function
and then Is_Predicate_Function (Subp_Id)
then
- raise Program_Error;
+ if V = Subp_Id then
+ return;
+ else
+ raise Program_Error;
+ end if;
end if;
Next_Elmt (Subp_Elmt);
end loop;
+
+ Prepend_Elmt (V, Subps);
end Set_Predicate_Function;
-----------------
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22575f9cbf5f..dcca3fc57aab 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -9986,6 +9986,12 @@ package body Sem_Ch13 is
-- Includes a call to the predicate function for type T in Expr if
-- Predicate_Function (T) is non-empty.
+ function Has_Source_Predicate (T : Entity_Id) return Boolean;
+ -- Return True if one of the 3 predicate aspects is specified
+ -- explicitly (either via a pragma or an aspect specification, but
+ -- not implicitly via propagation from some other type/subtype via
+ -- RM 3.2.4(5)) for the type/subtype T.
+
procedure Replace_Current_Instance_References
(N : Node_Id; Typ, New_Entity : Entity_Id);
-- Replace all references to Typ in the tree rooted at N with
@@ -10202,6 +10208,41 @@ package body Sem_Ch13 is
end loop;
end Add_Predicates;
+ --------------------------
+ -- Has_Source_Predicate --
+ --------------------------
+
+ function Has_Source_Predicate (T : Entity_Id) return Boolean is
+ Rep_Item : Node_Id := First_Rep_Item (T);
+ begin
+ while Present (Rep_Item) loop
+ case Nkind (Rep_Item) is
+ when N_Pragma =>
+ if Get_Pragma_Id (Rep_Item) = Pragma_Predicate
+ and then T = Entity (Expression
+ (First (Pragma_Argument_Associations (Rep_Item))))
+ then
+ return True;
+ end if;
+
+ when N_Aspect_Specification =>
+ if Get_Aspect_Id (Rep_Item) in
+ Aspect_Static_Predicate
+ | Aspect_Dynamic_Predicate | Aspect_Predicate
+ and then Entity (Rep_Item) = T
+ then
+ return True;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ Next_Rep_Item (Rep_Item);
+ end loop;
+ return False;
+ end Has_Source_Predicate;
+
-----------------------------------------
-- Replace_Current_Instance_References --
-----------------------------------------
@@ -10245,6 +10286,21 @@ package body Sem_Ch13 is
-- context where expansion and tests are enabled.
SId := Predicate_Function (Typ);
+
+ -- When declaring a subtype S whose "predecessor" subtype PS (that is,
+ -- the subtype denoted by the subtype_mark in the declaration of S)
+ -- already has a predicate function, do not confuse that existing
+ -- function for PS with the function we need to build for S if
+ -- Has_Source_Predicate returns True for S.
+
+ if Present (SId)
+ and then Nkind (Parent (Typ)) = N_Subtype_Declaration
+ and then Etype (First_Entity (SId)) /= Typ
+ and then Has_Source_Predicate (Typ)
+ then
+ SId := Empty;
+ end if;
+
if not Has_Predicates (Typ)
or else (Present (SId) and then Has_Completion (SId))
or else
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 679d0eee21be..c8e30f3dc7ff 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2176,6 +2176,7 @@ package body Sem_Util is
Def_Id : Entity_Id;
Btyp : Entity_Id := Base_Type (Typ);
+ Predicated_Parent_Used : Boolean := False;
begin
-- The Related_Node better be here or else we won't be able to
-- attach new itypes to a node in the tree.
@@ -2190,6 +2191,25 @@ package body Sem_Util is
and then Present (Underlying_Type (Btyp))
then
Btyp := Underlying_Type (Btyp);
+
+ -- If a predicate has been specified for an unconstrained
+ -- ancestor subtype, then that ancestor subtype needs to also
+ -- be an ancestor subtype for the subtype we are building so that
+ -- we don't lose the predicate. It is somewhat ugly here to have
+ -- to replicate the precondition for Predicated_Parent.
+
+ elsif Typ in E_Array_Subtype_Id
+ | E_Record_Subtype_Id
+ | E_Record_Subtype_With_Private_Id
+ and then Present (Predicated_Parent (Typ))
+ then
+ -- Assert that the following assignment is only changing the
+ -- subtype, not the type.
+
+ pragma Assert (Base_Type (Predicated_Parent (Typ)) = Btyp);
+
+ Btyp := Predicated_Parent (Typ);
+ Predicated_Parent_Used := True;
end if;
Indic :=
@@ -2211,7 +2231,10 @@ package body Sem_Util is
Analyze (Subtyp_Decl, Suppress => All_Checks);
- if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
+ if Is_Itype (Def_Id)
+ and then Has_Predicates (Typ)
+ and then not Predicated_Parent_Used
+ then
Inherit_Predicate_Flags (Def_Id, Typ);
-- Indicate where the predicate function may be found
