In determining at run time whether a statically-known discrete value
satisifies the predicate of a subtype where both
- a Dynamic_Predicate aspect specification applies (directly or
indirectly) to a subtype; and
- at least one other predicate aspect specification (that is, either
a Static_Predicate aspect specification, a GNAT-defined Predicate
aspect specification, or a second Dynamic_Predicate aspect
specification) applies (directly or indirectly) to that same
subtype,
sometimes only the "last" Dynamic_Predicate aspect's condition was
checked; the other predicate aspects were incorrectly ignored. This
could result in a subtype membership test incorrectly yielding a result
of True. This error is corrected.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch6.adb (Can_Fold_Predicate_Call): Do not attempt folding
if there is more than one predicate involved. Recall that
predicate aspect specification are additive, not overriding, and
that there are three different predicate
aspects (Dynamic_Predicate, Static_Predicate, and the
GNAT-defined Predicate aspect). These various ways of
introducing multiple predicates are all checked for. A new
nested function, Augments_Other_Dynamic_Predicate, is
introduced.
* sem_ch4.adb
(Analyze_Indexed_Component_Form.Process_Function_Call): When
determining whether a name like "X (Some_Discrete_Type)" might
be interpreted as a slice, the answer should be "no" if the
type/subtype name denotes the current instance of type/subtype.diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3143,6 +3143,13 @@ package body Exp_Ch6 is
function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
Actual : Node_Id;
+ function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
+ return Boolean;
+ -- Given a Dynamic_Predicate aspect aspecification for a
+ -- discrete type, returns True iff another DP specification
+ -- applies (indirectly, via a subtype type or a derived type)
+ -- to the same entity that this aspect spec applies to.
+
function May_Fold (N : Node_Id) return Traverse_Result;
-- The predicate expression is foldable if it only contains operators
-- and literals. During this check, we also replace occurrences of
@@ -3150,6 +3157,36 @@ package body Exp_Ch6 is
-- value of the actual. This is done on a copy of the analyzed
-- expression for the predicate.
+ --------------------------------------
+ -- Augments_Other_Dynamic_Predicate --
+ --------------------------------------
+
+ function Augments_Other_Dynamic_Predicate (DP_Aspect_Spec : Node_Id)
+ return Boolean
+ is
+ Aspect_Bearer : Entity_Id := Entity (DP_Aspect_Spec);
+ begin
+ loop
+ Aspect_Bearer := Nearest_Ancestor (Aspect_Bearer);
+
+ if not Present (Aspect_Bearer) then
+ return False;
+ end if;
+
+ declare
+ Aspect_Spec : constant Node_Id :=
+ Find_Aspect (Aspect_Bearer, Aspect_Dynamic_Predicate);
+ begin
+ if Present (Aspect_Spec)
+ and then Aspect_Spec /= DP_Aspect_Spec
+ then
+ -- Found another Dynamic_Predicate aspect spec
+ return True;
+ end if;
+ end;
+ end loop;
+ end Augments_Other_Dynamic_Predicate;
+
--------------
-- May_Fold --
--------------
@@ -3192,7 +3229,7 @@ package body Exp_Ch6 is
function Try_Fold is new Traverse_Func (May_Fold);
- -- Other lLocal variables
+ -- Other Local variables
Subt : constant Entity_Id := Etype (First_Entity (P));
Aspect : Node_Id;
@@ -3220,6 +3257,11 @@ package body Exp_Ch6 is
or else Nkind (Actual) /= N_Integer_Literal
or else not Has_Dynamic_Predicate_Aspect (Subt)
or else No (Aspect)
+
+ -- Do not fold if multiple applicable predicate aspects
+ or else Present (Find_Aspect (Subt, Aspect_Static_Predicate))
+ or else Present (Find_Aspect (Subt, Aspect_Predicate))
+ or else Augments_Other_Dynamic_Predicate (Aspect)
or else CodePeer_Mode
then
return False;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2534,6 +2534,7 @@ package body Sem_Ch4 is
and then Is_Entity_Name (Actual)
and then Is_Type (Entity (Actual))
and then Is_Discrete_Type (Entity (Actual))
+ and then not Is_Current_Instance (Actual)
then
Replace (N,
Make_Slice (Loc,
